麻辣家族討論版版 - Powered by Discuz! Board

Sub ex()
On Error Resume Next
Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
Set d = CreateObject("Scripting.Dictionary")
Set sht = Sheets.Add(after:=Sheets(1))
Application.ScreenUpdating = False
With Sheet1
For Each A In .Range(.[A2], .[A65536].End(xlUp))
mystr = A & "," & Left(A.Offset(, 1), 4)
'你Sheet1的A欄是以日期格式yyyy/m/d輸入，但格式設成yyyymmdd，所以，造成非全部為8碼
'用TEXT屬性得到所見字串
d(mystr) = DateValue(Format(A.Offset(, 1).Text, "0000/00/00"))
If Err.Number <> 0 Then MsgBox A & A.Offset(, 1)
Next
End With
k = 1: r = 1
For Each ky In d.keys
y = Split(ky, ",")(1)
With Sheets(y)
Set C = .Columns("A").Find(d(ky))
Set B = .Rows(1).Find(Split(ky, ",")(0))
If Not C Is Nothing And Not B Is Nothing Then
x = Application.Max(3, C.Row - 14)
Set Rng = .Cells(x, 1).Resize(15, 1)
Set Rng1 = .Cells(x, B.Column).Resize(15, 1)
With sht
Rng.Copy .Cells(r, k)
Rng1.Copy .Cells(r, k + 1)
.Cells(r, 3) = y & "年第" & B.Column - 1 & "筆"
End With
r = r + 15
Else
MsgBox "無此除權資料"
End If
End With
Next
Application.ScreenUpdating = True
End Sub

複製代碼