求助！批量新建xls文件

imagicgyj

哪位大神帮忙修改成批量生成XLS文件




Sub 批量新建文件夹()
    Dim i As Integer '用于下方数组
    Dim Arr1(), Arr2() '定义一个数组，不能定义大小和类型
    Dim Fso, Fld    '定义文件路径
    Dim rowmax  '找到数据的行数

    start_time = Timer  '计时开始

'数据的行数
    rowmax = [A1048576].End(xlUp).Row
'把两列数据分别赋值给两个个数组
    Arr1 = Range("A2:A" & rowmax)
    Arr2 = Range("B2:B" & rowmax)
'选择建文件夹的路径
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Fld = Fso.getfolder(CreateObject("Shell.Application").BrowseForFolder(0, "请选择需要创建文件夹的根目录", 0, "").Self.Path & "")

'开始批量新建文件夹
    For i = 1 To UBound(Arr1)
        folderName = Arr1(i, 1) & " " & Arr2(i, 1)
        If Dir(Fld & "\" & folderName, vbDirectory) = vbNullString Then  '如果文件夹不存在，则新建
        VBA.MkDir (Fld & "\" & folderName)
        End If
    Next
'建好了
MsgBox "OK"


    cost_time = Timer - start_time  '计时结束，计算用时
    Range("C1") = cost_time
End Sub

ykcbf1100

建议上传附件。

3190496160

上传附件才好测试代码

limonet

哪位有量子技术，把附件上传一下。

imagicgyj

附件已上传，拜托各位大神！

limonet

你到底是要新建“文件”还是“文件夹”？

imagicgyj

limonet 发表于 2024-8-8 11:36
你到底是要新建“文件”还是“文件夹”？

新建文件，这个是之前用来新建文件夹的想到这个上面修改

ykcbf1100

imagicgyj 发表于 2024-8-8 12:00
新建文件，这个是之前用来新建文件夹的想到这个上面修改

批量新建文件

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.8
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     p = ThisWorkbook.Path & ""
   
5.     On Error Resume Next
   
6.     With Sheets("3-Create Folder")
   
7.         r = .Cells(Rows.Count, 1).End(3).Row
   
8.         For i = 2 To r
   
9.             fn = .Cells(i, 1)
   
10.             Set wb = Workbooks.Add
    
11.             wb.SaveAs Filename:=p & fn & ".xls", FileFormat:=56
    
12.             wb.Close
    
13.         Next
    
14.     End With
    
15.     Application.ScreenUpdating = True
    
16.     MsgBox "OK！"
    
17. End Sub
    
18. 
    

复制代码

limonet

关键字：new-item