|
代码如下。。。
Sub test()
Dim wb As Workbook, sht As Worksheet
Set wb = ThisWorkbook
Set sht = wb.Sheets("sheet1")
r = sht.Cells(sht.Rows.Count, 1).End(3).Row
arr = sht.[a1].Resize(r, 2)
Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "选择创建新文件夹。。。"
.InitialFileName = wb.Path & "\"
If .Show = -1 Then fpath = .SelectedItems(1) & "\" Else MsgBox "没有选择文件夹,退出!!": Exit Sub
End With
Application.ScreenUpdating = False
For i = 2 To UBound(arr)
For j = 1 To 2
If arr(i, j) = Empty Then
arr(i, j) = arr(i - 1, j)
End If
Next
Next
For i = 2 To UBound(arr)
p = fpath & arr(i, 1) & "\"
s = p & arr(i, 2) & ".xls"
If Not fso.FolderExists(p) Then fso.CreateFolder p
If Not fso.FileExists(s) Then
With Workbooks.Add
.SaveAs s, 56
.Close 0
End With
End If
Next
Application.ScreenUpdating = True
Beep
End Sub
|
评分
-
2
查看全部评分
-
|