asus103

GBKEE¡G
«D±`·PÁ±z!!!!
§Ú²{¦b°¨¤W³B²z¡A¥ý·PÁ±zªº¶O¤ß

GBKEE

¦^´_ 1# asus103

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D(1) As Object, F As Range, MyClass$, F_Address$, Rng As Range, C, R, D_Key$, ARng As Range
   
4.     Set D(0) = CreateObject("SCRIPTING.DICTIONARY")
   
5.     Set D(1) = CreateObject("SCRIPTING.DICTIONARY")
   
6.     With Sheets("Sheet1")
   
7.         Set F = .Range("B:B").Find(what:="¾Ç¡@¸¹", After:=.[b1], Lookat:=xlWhole)
   
8.         If Not F Is Nothing Then
   
9.             F_Address = F.Address
   
10.             Do
    
11.                 Set Rng = .Range(F, F.End(xlToRight).End(xlDown))
    
12.                 MyClass = F.Offset(-2)
    
13.                 For Each C In Rng.Columns(1).Cells
    
14.                     If IsNumeric(C) Then
    
15.                         D_Key = C & "," & C(1, 2) & "," & MyClass & "," & C(1, 3)
    
16.                         D(0)(D_Key) = ""
    
17.                         For R = 4 To Rng.Columns.Count
    
18.                             If Rng(1, R) <> "" Then D(1)(D_Key & Rng(1, R)) = .Cells(C.Row, Rng(1, R).Column)
    
19.                         Next
    
20.                     End If
    
21.                 Next
    
22.                 Set F = .Range("B:B").FindNext(F)
    
23.             Loop While F_Address <> F.Address
    
24.             With Sheets("Sheet4")
    
25.                 .UsedRange.Offset(1).Clear
    
26.                 For Each R In D(0).KEYS
    
27.                     Set ARng = .Range("A" & Rows.Count).End(xlUp).Offset(1)
    
28.                     ARng.Resize(, 4) = Split(R, ",")
    
29.                     For C = 5 To .[A1].End(xlToRight).Column
    
30.                         If .Cells(1, C) <> "" Then ARng(1, C) = D(1)(R & .Cells(1, C))
    
31.                     Next
    
32.                 Next
    
33.             End With
    
34.         End If
    
35.     End With
    
36. End Sub

½Æ»s¥N½X