另存工作簿

ddz79101

老师！有工作表，我现已将其2部分分别存为同簿2表，但，我还想将其分别另存为工作簿，要求是此工作簿在路径不确定情况下，选择文件夹保存。谢谢老师指点路径代码怎么写

cidanji

1. Sub ss()
   
2.     Dim ws, p$
   
3.     '文件夹选择
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         .InitialFileName = ThisWorkbook.Path '默认对话框路径
   
6.         .AllowMultiSelect = False '禁多选
   
7.         If .Show = -1 Then p = .SelectedItems(1) Else Exit Sub ' 显示对话框（取消会exit）
   
8.     End With
   
9.     '另存
   
10.     For Each ws In Worksheets(Array("甲", "乙"))
    
11.         ws.Copy
    
12.         Application.DisplayAlerts = False
    
13.         ActiveWorkbook.SaveAs p & "" & ws.Name & ".xls"
    
14.         Application.DisplayAlerts = True
    
15.         ActiveWorkbook.Close
    
16.     Next
    
17. End Sub

复制代码

ddz79101

cidanji 发表于 2024-5-26 09:24

谢谢老师！我任意选了个文件夹，没有生成2个文件（簿）吗

ddz79101

ddz79101 发表于 2024-5-26 10:30
谢谢老师！我任意选了个文件夹，没有生成2个文件（簿）吗

有老师帮忙看看吗

ddz79101

ddz79101 发表于 2024-5-26 11:41
有老师帮忙看看吗

有老师帮忙看看吗

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.5.26
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     fn = [{"甲","乙"}]
   
5.     Set sh = ThisWorkbook.Sheets("表")
   
6.     With sh
   
7.         For x = 1 To UBound(fn)
   
8.             c = 1 + (x - 1) * 5
   
9.             r = .Cells(Rows.Count, c).End(3).Row
   
10.             arr = .Cells(1, c).Resize(r, 4)
    
11.             With Sheets(fn(x))
    
12.                 .Cells.ClearContents
    
13.                 .Name = fn(x)
    
14.                 .[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
15.                 .Range("A:D").Columns.AutoFit
    
16.             End With
    
17.             Sheets(fn(x)).Copy
    
18.             Set wb = ActiveWorkbook
    
19.             With Application.FileDialog(msoFileDialogFolderPicker)
    
20.                 .Title = "请选择文件夹"
    
21.                 .InitialFileName = ThisWorkbook.Path & ""
    
22.                 If .Show = -1 Then
    
23.                     p = .SelectedItems(1) & ""
    
24.                 End If
    
25.             End With
    
26.             wb.SaveAs p & fn(x), 56
    
27.             wb.Close
    
28.         Next
    
29.     End With
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    
33. 
    

复制代码

ddz79101

cidanji 发表于 2024-5-26 09:24

老师！在吗

ykcbf1100

ddz79101 发表于 2024-5-26 14:02
老师！在吗

我都回复了，你看不到吗？

ddz79101

ykcbf1100 发表于 2024-5-26 14:01
附件供参考。。。

谢谢老师！我在选择文件夹时，出现下面错误