- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
2#
發表於 2010-12-28 14:13
| 只看該作者
回復 1# asus103 - Option Explicit
- Sub Ex()
- Dim D(1) As Object, F As Range, MyClass$, F_Address$, Rng As Range, C, R, D_Key$, ARng As Range
- Set D(0) = CreateObject("SCRIPTING.DICTIONARY")
- Set D(1) = CreateObject("SCRIPTING.DICTIONARY")
- With Sheets("Sheet1")
- Set F = .Range("B:B").Find(what:="學 號", After:=.[b1], Lookat:=xlWhole)
- If Not F Is Nothing Then
- F_Address = F.Address
- Do
- Set Rng = .Range(F, F.End(xlToRight).End(xlDown))
- MyClass = F.Offset(-2)
- For Each C In Rng.Columns(1).Cells
- If IsNumeric(C) Then
- D_Key = C & "," & C(1, 2) & "," & MyClass & "," & C(1, 3)
- D(0)(D_Key) = ""
- For R = 4 To Rng.Columns.Count
- If Rng(1, R) <> "" Then D(1)(D_Key & Rng(1, R)) = .Cells(C.Row, Rng(1, R).Column)
- Next
- End If
- Next
- Set F = .Range("B:B").FindNext(F)
- Loop While F_Address <> F.Address
- With Sheets("Sheet4")
- .UsedRange.Offset(1).Clear
- For Each R In D(0).KEYS
- Set ARng = .Range("A" & Rows.Count).End(xlUp).Offset(1)
- ARng.Resize(, 4) = Split(R, ",")
- For C = 5 To .[A1].End(xlToRight).Column
- If .Cells(1, C) <> "" Then ARng(1, C) = D(1)(R & .Cells(1, C))
- Next
- Next
- End With
- End If
- End With
- End Sub
|
|
發表於 2010-12-28 10:00
| 
