­ã´£³¡ªL

¨S¸Ô²Ó¬Ý­n§ì¤°»ò¼Æ¾Ú, ÀH«K¼g¤@­Ó°Ñ¦Ò, ¦Û¦æ¤F¸Ñµ{¦¡½X¦A®Ú¾Ú»Ý¨D§ï§ï:
Sub ½LÂI_´Áªì®w¦s()
Dim Arr, DD, PH$, FN1$, FN2$, FT$
Dim xB1 As Workbook, xS1 As Worksheet, xB2 As Workbook, xS2 As Worksheet
Dim xF1 As Range, xF2 As Range, TT$, DY
Application.ScreenUpdating = False
PH = ThisWorkbook.Path & "\"
FN2 = Range("B8")
If FN2 = "" Then MsgBox "«ü©wÀɦWºÙ¥¼¿é¤J!  ": Exit Sub
FN2 = Dir(PH & FN2 & "*.xls*")
If FN2 = "" Then MsgBox "«ü©wÀɤ£¦s¦b!  ": Exit Sub
'----------------------------------
FN1 = "¦h«È¤á½LÂIªí.xls"
On Error Resume Next: Set xB1 = Workbooks(FN1): On Error GoTo 0
If xB1 Is Nothing Then Set xB1 = Workbooks.Open(PH & FN1)
'-----------------------------------
On Error Resume Next: Set xB2 = Workbooks(FN2): On Error GoTo 0
If xB2 Is Nothing Then Set xB2 = Workbooks.Open(PH & FN2)
FT = Split(FN2, "­Ü®w")(0) 'ºI¨ú[«È¤á]¦WºÙ
'-----------------------------------
ThisWorkbook.Activate
Set xS1 = xB1.Sheets("½LÂI")
DD = xS1.[e4]
Arr = Range(xS1.[di1], xS1.[a6536].End(3))
For i = 6 To UBound(Arr) Step 2
    TT = Arr(i, 5) '«~¦W
    DY = Day(DD + Arr(i, UBound(Arr, 2)) - 1) '¤é´Á--day..¥H di Äæ¨ú·í¤Ñ©Î«e¤@¤Ñ
    If Arr(i, 1) <> FT Or TT = "" Then GoTo i01
    On Error Resume Next: Set xS2 = xB2.Sheets(DY & ""): On Error GoTo 0
    If xS2 Is Nothing Then GoTo i01
    Set xF1 = xS2.Cells.Find("´Á¥½", Lookat:=xlWhole) '§ä[´Á¥½®w¦s]¦ì¸m
    Set xF2 = xS2.[b:b].Find(TT, Lookat:=xlWhole) '§äBÄæ[«~¦W]¦ì¸m
    If xF1 Is Nothing Or xF2 Is Nothing Then GoTo i01
    xS1.Cells(i, 13) = xS2.Cells(xF2.Row, xF1.Column)
i01: Next i
MsgBox "´Áªì®w¦s¸ü¤J§¹¦¨, ¦h«È¤á½LÂIªí©|¥¼Àx¦s, ­Y½T©wµL»~¦A¤â°Ê¦sÀÉ!  "
End Sub

­ã´£³¡ªL

¦^´_ 52# PJChen


Sub ½LÂI_«ü©w¤é¼Æ¶q_¸ü¤J()
Dim Arr, Brr, Crr(1 To 25), xD, i&, j%, k%
Dim xB As Workbook, xS As Worksheet, xNN$, vB As Workbook, vS As Worksheet, vNN$
Dim PH$, xN$, DD, D$(1), xF As Range
Application.ScreenUpdating = False
Set xD = CreateObject("Scripting.Dictionary")
PH = ThisWorkbook.Path & "\"
vNN = Range("B8")
If vNN = "" Then MsgBox "«ü©wÀɦWºÙ¥¼¿é¤J!  ": Exit Sub
vNN = Dir(PH & vNN & "*.xls*")
If vNN = "" Then MsgBox "«ü©wÀɤ£¦s¦b!  ": Exit Sub
'----------------------------------
xNN = "¦h«È¤á½LÂIªí.xls"
On Error Resume Next: Set xB = Workbooks(xNN): On Error GoTo 0
If xB Is Nothing Then Set xB = Workbooks.Open(PH & xNN)
Set xS = xB.Sheets("½LÂI"): DD = CDate(xS.[e4])
D(0) = Day(DD - 1): D(1) = Day(DD)
Arr = Range(xS.[di1], xS.[a6536].End(3))
'-----------------------------------
On Error Resume Next: Set vB = Workbooks(vNN): On Error GoTo 0
If vB Is Nothing Then Set vB = Workbooks.Open(PH & vNN)
For k = 0 To 1
    Set vS = vB.Sheets(D(k) & "")
    Brr = vS.UsedRange
    Set xF = vS.Cells.Find("½LÂI", Lookat:=xlWhole).MergeArea
    For i = xF.Row + 2 To UBound(Brr) Step 2
        If Brr(i, 2) = "" Then GoTo i01 '«~¦WªÅ¥Õ
        For j = xF.Column To xF.Column + xF.Columns.Count - 1
            xD(Brr(i, 2) & "|" & k & "|" & CLng(Brr(i, j))) = Brr(i + 1, j)
        Next j
i01: Next i
Next k
vB.Close 0
'-----------------------------------
For i = 6 To UBound(Arr) Step 2
    If InStr("/" & vNN, Arr(i, 1)) <> 2 Or Arr(i, 5) = "" Then GoTo i02 '«È¤á¦WºÙ¤ñ¹ï
    For j = 1 To UBound(Crr)
        Crr(j) = xD(Arr(i, 5) & "|" & Arr(i, UBound(Arr, 2)) & "|" & CLng(Arr(i, j + 59)))
    Next j
    xS.Cells(i + 1, 60).Resize(1, UBound(Crr)) = Crr:   Erase Crr()
i02: Next i
xB.Activate: xS.Activate
Erase Arr, Brr: Set xD = Nothing: Set xB = Nothing: Set vB = Nothing: Set xS = Nothing: Set vS = Nothing
MsgBox "½LÂI¼Æ¶q¸ü¤J§¹¦¨, ¦h«È¤á½LÂIªí©|¥¼Àx¦s, ­Y½T©wµL»~¦A¤â°Ê¦sÀÉ!  "
End Sub