VBA把一个工作表拆分成多个工作簿，想在保存的文件名上加个前缀

杨大大虾

练习文件上已经有VBA，实现功能是：把原文件以A列（团队）为条件，拆分成多个工作薄文件，文件自动以“团队1”、“团队2”、“团队3”、“团队4”保存




现在想在拆分保存时，加个自定义前缀，比如拆分保存的文件以“业绩-团队1”、“业绩-团队2”、“业绩-团队3”、“业绩-团队4”保存。


请各位老师指导，感谢。

gwjkkkkk

请参考。。。

杨大大虾

gwjkkkkk 发表于 2023-4-18 22:57
请参考。。。

我的意思是在原有功能不变的情况下，再弹出一个提示窗让我填写前缀名称
还是感谢~

f8b1987

杨大大虾 发表于 2023-4-18 23:36
我的意思是在原有功能不变的情况下，再弹出一个提示窗让我填写前缀名称
还是感谢~

你这是别人写好了，再提新想法.......前面就没说过弹窗出来填写

自己在程序开头加句bb=Application.InputBox("请输入自定义内容")，

然后把bb传递给Saveas

ykcbf1100

杨大大虾 发表于 2023-4-18 23:36
我的意思是在原有功能不变的情况下，再弹出一个提示窗让我填写前缀名称
还是感谢~

加入文件前辍

mmwwdd

Sub test()
Set d = CreateObject("scripting.dictionary")
With Sheet1
    arr = .Range("A1").CurrentRegion
    For i = 2 To UBound(arr)
     If Not d.exists(arr(i, 1)) Then
        ReDim brr(1 To 6, 1 To 1)
        For j = 2 To 7
           brr(j - 1, 1) = arr(i, j)
        Next
        d(arr(i, 1)) = brr
        Erase brr
     Else
        brr = d(arr(i, 1))
'        brr = Application.Transpose((brr))
        n = UBound(brr, 2)
        n = n + 1
        ReDim Preserve brr(1 To 6, 1 To n)
       For j = 2 To 7
            brr(j - 1, n) = arr(i, j)
       Next
       d(arr(i, 1)) = brr
        Erase brr
    End If
   Next
   For Each aa In d.keys
           xm = aa
           sz = Application.Transpose(d(aa))
           Workbooks.Add
           With ActiveWorkbook.Sheets(1)
             .Range("B1").Resize(UBound(sz), UBound(sz, 2)) = sz
             .Range("A1").Resize(UBound(sz)) = aa
            
           End With
           ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & aa & ".xls"
           ActiveWorkbook.Close True
Next
          .Range("a17").Resize(1, UBound(k) + 1) = k
End With
End Sub