[µo°Ý] ¹ïÀ³¤é´Á¶K½LÂI¸ê®Æ

PJChen

¤j¤j­Ì¦n,
    With Sh
    Sh.Activate
        For j = 6 To xrow Step 2
            .Range("X" & j + 1 + 1).Resize(1, 16).Copy
            xW.Sheets("½LÂI").Range("BO" & 1 + j).Resize(1, 16).PasteSpecial xlPasteValues
        Next
    End With
½LÂI¤u§@ªí±qAÄ檺¦U«È¤áÀɮקâ¬ÛÀ³ªº½LÂI¸ê®Æ,copy¹L¨Ó
E4¬O«ü©w¤é´Á
AÄæ¬O«È¤á¦W
·íDIÄæ= D+0«h±q«È¤áÀɮתº¼Æ¦r¤u§@ªí§äE4-1ªº¤u§@ªí
ex:E4=7/3,«h§ä"2"¤u§@ªí
±Nx:amªº½LÂI¸ê®Æ,¦³®w¦sªº¼Æ¦r,¹ïÀ³¤é´Á¬Û²Å,¶K¨ì½LÂI¤u§@ªíªºBH:CFªºÄæ¦ì¤¤

¨Ó·½¦U«È¤áªºÀɮ׮榡¤£·|§¹¥þ¬Û¦P,¦ý³£¬OÃþ¦üªº,¥u¥H¤@©w§@½d¥»,
½LÂI¤u§@ªí¤¤¦³«Ü¦hªº¤½¦¡,©Ò¥H¶K¤Wªº¸ê®Æ¤£¯à¤zÂZ¨ä¥LÀx¦s®æ,
½Ð°Ý(¬õ¦r)¹ïÀ³¤é´Á¶K¤W½LÂI¼Æ­Èªº³o¬qµ{¦¡¸Ó«ç»ò¼g?   ¶K½LÂI¸ê®Æ.rar (328.03 KB)

¤U¸ü¦¸¼Æ: 10

2021-7-4 13:32

1. Sub copy_»e¸Á½LÂI()
   
2. Dim PH$, FN$, W As Workbook, xW As Workbook, xD As Worksheet, xS As Worksheet, Sh As Worksheet, i As String, rng As Range
   
3. Set xD = ThisWorkbook.Sheets("VBA")  'µ{¦¡¨Ó·½
   
4. k = xD.[V1] - 1 '¨ú«e¤@¤é
   
5. i = Format(k, "D")
   
6. y = Format(k, "yyyy")
   
7. m = Format(k, "m")
   
8. '---------------------
   
9. Set xW = Workbooks("¦h«È¤á½LÂIªí")
   
10. PH = xD.[BB1]
    
11. '---------------------
    
12. FN = Dir(PH & "*»e¸Á*" & y & "*" & m & ".xlsx")
    
13. Do While FN <> ""
    
14. On Error Resume Next: Set W = Workbooks(FN): On Error GoTo 0
    
15. If W Is Nothing Then Set W = Workbooks.Open(PH & FN)
    
16. Set Sh = W.Sheets(i)
    
17. With Sh
    
18.     xrow = Cells(Cells.Rows.Count, "A").End(xlUp).Row + 5
    
19. End With
    
20.      xW.Sheets("½LÂI").Range("M6:M" & xrow) = Sh.Range("T7:T" & xrow).Value '¨Ó·½ «e¤éµ²¾l   
    
21. With Sh
    
22.     Sh.Activate
    
23.         For j = 6 To xrow Step 2
    
24.             .Range("X" & j + 1 + 1).Resize(1, 16).Copy
    
25.             xW.Sheets("½LÂI").Range("BO" & 1 + j).Resize(1, 16).PasteSpecial xlPasteValues
    
26.         Next
    
27.     End With
    
28.    
    
29. FN = Dir
    
30. Loop
    
31. End Sub

½Æ»s¥N½X

PJChen

¦^´_ 53# ­ã´£³¡ªL
­ã¤j¦n,

´ú¸Õ¦h¤é,´Áªì&½LÂI¸ê®Æ,³£¥¿½T...
·PÁ¡I

­ã´£³¡ª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

PJChen

¦^´_ 50# ­ã´£³¡ªL

­ã¤j¦n,

1) FT = Split(FN2, "®w¦sªí")(0)
«È¤áÀɦW¤j¦h¥HXXX®w¦sªí ©R¦W

¦ýFT = Split(FN2, "®w¦sªí")(0) 'ºI¨ú[«È¤á]¦WºÙ
³o¸Ì¬O¥Î³Ì¤j¦h¼Æªº"®w¦sªí"¨Ó¤ÀÂ÷¦r¦ê
¦ý¦]¬°¦P¤@«È¤á¦³¤£¦P¼t§O,
¨Ò¦p¡G¨Î¨Î¤¤Ãc¼t®w¦sªí
¦b[B8]·|¿é¤J"¨Î¨Î¤¤Ãc¼t®w¦sªí"
³o¼Ë¤S·|§ì¤£¨ìÀÉ®×
½Ð°Ý¦p¦ó­×§ï?
FT = Split(FN2, "®w¦sªí")(0)

2)
±Nµ{¦¡§ï¬°§ì¨ú½LÂI¸ê®Æ®É,
Áٻݭn¥[¤J¤@¬q¤ñ¹ï¤é´Áªºµ{¦¡
¤ñ¹ï³W«h
«È¤á®w¦sªíªº²Ä7¦C,¹ïÀ³"¦h«È¤á½LÂIªí"ªº²Ä6¦C
½Ð°Ý¥H¤Uµ{¦¡­n«ç»ò­×§ï?
    Set xF1 = xS2.Cells.Find("½LÂI", Lookat:=xlWhole) '§ä«È¤á[½LÂI]¦ì¸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, 60) = xS2.Cells(xF2.Row, xF1.Column) '¦h«È¤á½LÂIÄæ=60

°a¤ªºµ

¦^´_ 50# ­ã´£³¡ªL

ÁÂÁ ·Ç¤j ¤p§Ì¬ã¨s¤@¤U ·PÁÂ

­ã´£³¡ª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

°a¤ªºµ

¦^´_ 48# PJChen

µo²{½LÂIµL¼Æ¾Ú®É,µLªk¶K¤W´Áªì­È    <----§â§PÂ_µù¸Ñ¤F

¤w¸g§âµ{¦¡ ½Æ»s¨Ã¤À¶}¤F ¦³ªÅ¦AÀ°§Ú¸Õ¸Õ¬Ý ¦³°ÝÃD¦A¸ò§Ú»¡ ·PÁÂ


Macro_1_1215.rar (44.32 KB)

¤U¸ü¦¸¼Æ: 1

2021-12-15 08:51

PJChen

¦^´_ 47# °a¤ªºµ
ºµ¤j¦n,
½Ð°Ý²{±N´Áªì&½LÂI¦X¬°¤@­Óµ{¦¡,­ì¥ý¬O§Æ±æ¤À¦¨¤G­Óµ{¦¡ªº¡I
¦]¬°¦³®É·|¤À¶}¨Ï¥Î....

¥Ø«e¥u¯à¥ý¥H´ú¸ÕÀÉ´ú¸Õ
µo²{½LÂIµL¼Æ¾Ú®É,µLªk¶K¤W´Áªì­È

°a¤ªºµ

¦^´_ 45# PJChen

³o¬O¥[¤J ´Á¥½©M½LÂI ¤@°_¤ñ¹ï ¦³ªÅ¦AÀ°§Ú¸Õ¸Õ¬ÝÁÙ¦³¨S¦³°ÝÃD ·PÁÂ

Macro_1_1214_.rar (40.71 KB)

¤U¸ü¦¸¼Æ: 1

2021-12-14 14:20

°a¤ªºµ

¦^´_ 45# PJChen

¦³ªÅ¦AÀ°§Ú¸Õ¸Õ¬Ý¦æ¤£¦æ ·PÁ  ¦ý °j°éÅܦh¤F¥Î¤F7­Ó°j°é..... ³t«×¤]·|ÅܺC¬Ý¬Ý¦³¨S¦³¤j¤j¥i¥HÀ°¦£^^"
    javascript:;