擷取報表中所需資料 - Excel程式區

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

1^# 跳轉到 »

發表於 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