|
同名文件数据复制
- Sub ykcbf() '//2025.1.20
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set fso = CreateObject("Scripting.FileSystemObject")
- p = ThisWorkbook.Path & ""
- p1 = p & "2025"
- p2 = p & "2026"
- On Error Resume Next
- For Each f In fso.GetFolder(p2).Files
- f.Name = Split(fso.GetBaseName(f), "-")(0) & "-2026." & fso.GetExtensionName(f)
- Next f
- For Each f In fso.GetFolder(p1).Files
- If LCase$(f.Name) Like "*.xls*" Then
- fn = f.Name
- Set wb = Workbooks.Open(f, 0)
- Set wb2 = Workbooks.Open(p2 & fso.GetBaseName(f) & "-2026." & fso.GetExtensionName(f), 0)
- For Each sht In wb.Sheets
- With sht
- r = .Cells(Rows.Count, "l").End(3).Row
- arr = .Range("l2:t" & r)
- xm = .Name
- wb2.Sheets(xm).Range("l2:t" & r) = arr
- End With
- Next
- wb.Close 0
- wb2.Close 1
- End If
- Next f
- For Each f In fso.GetFolder(p2).Files
- f.Name = Split(fso.GetBaseName(f), "-")(0) & "." & fso.GetExtensionName(f)
- Next f
- Application.ScreenUpdating = True
- MsgBox "OK!"
- End Sub
复制代码
|
|