求代码

施学明

将d盘批量下拨文件夹下的所有含有“2024”文件名的工作簿中“批量下拨”工作表中数据复制到“批量调拨模版”的工作簿中，然后分别另存为同一文件夹下与原xlsx同名的97-2003的工作簿（将原来的xlsx文件直接打开另存为xls工作簿不好导入数据库）

ykcbf1100

附件做得不认真，既没有下拨文件夹，也没有另存文件夹，更没有”批量下拨“工作表

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.8.7
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     p = ThisWorkbook.Path & ""
   
6.     f1 = p & "批量调拨(模版）.xls"
   
7.     p1 = p & "下拨文件夹"
   
8.     p2 = p & "文件另存"
   
9.     For Each f In fso.GetFolder(p1).Files
   
10.         If LCase$(f.Name) Like "*2024*.xls*" Then
    
11.             fn = fso.GetBaseName(f)
    
12.             Set wb = Workbooks.Open(f, 0)
    
13.             With wb.Sheets("Sheet1")
    
14.                 r = .Cells(Rows.Count, 1).End(3).Row
    
15.                 c = .Cells(1, "XFD").End(1).Column
    
16.                 arr = .[a2].Resize(r - 1, c)
    
17.             End With
    
18.             wb.Close 0
    
19.             Set wb = Workbooks.Open(f1, 0)
    
20.             wb.Sheets("Sheet1").[a2].Resize(UBound(arr), UBound(arr, 2)) = arr
    
21.             wb.SaveAs Filename:=p2 & fn & ".xls", FileFormat:=56
    
22.             wb.Close
    
23.         End If
    
24.     Next f
    
25.     Application.ScreenUpdating = True
    
26.     MsgBox "OK！"
    
27. End Sub
    

复制代码

kyxfyzg

Sub test()
Dim wbnm As String, wb As Workbook, sht As Worksheet, sh As Worksheet, h, n
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sh = ThisWorkbook.Sheets(1)
wbnm = Dir(ThisWorkbook.Path & "\*.xlsx")
Do
    If wbnm <> ThisWorkbook.Name Then
        Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & wbnm)
        For Each sht In wb.Sheets
            h = sht.UsedRange.Rows.Count
            n = sh.Range("a1").CurrentRegion.Rows.Count + 1
            Range("a2:s" & h).Copy sh.Cells(n, 1)
        Next sht
        wbnm = Replace(wbnm, ".xlsx", ".xls")
        wb.SaveAs ThisWorkbook.Path & "\" & wbnm
        wb.Close
    End If
wbnm = Dir
Loop Until wbnm = ""
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

ykcbf1100

kyxfyzg 发表于 2024-8-7 14:29
Sub test()
Dim wbnm As String, wb As Workbook, sht As Worksheet, sh As Worksheet, h, n
Application ...

你这代码这里不适用，模板文件都没有用到。

kyxfyzg

ykcbf1100 发表于 2024-8-7 15:05
你这代码这里不适用，模板文件都没有用到。

代码要在模板文件里运行

ykcbf1100

kyxfyzg 发表于 2024-8-7 15:11
代码要在模板文件里运行

你干脆上个附件好了。帮人帮到底。

kyxfyzg

ykcbf1100 发表于 2024-8-7 15:17
你干脆上个附件好了。帮人帮到底。

看看这个可以不？

ykcbf1100

kyxfyzg 发表于 2024-8-7 15:38
看看这个可以不？

你的附件里没有代码。
你自己没调试过代码吗？

kyxfyzg

ykcbf1100 发表于 2024-8-7 15:41
你的附件里没有代码。
你自己没调试过代码吗？

不好意思，上个传错了，这个模版文件里有。我试过了，你看看吧