按店铺名称，分成多个工作簿

yeu118

按店铺名称，分成多个工作簿。想让表中的数据，按店铺名称，　分成多个工作簿。按店铺的名称做为文件名。

该如何弄呢，谢谢了。

wang-way

https://club.excelhome.net/forum ... ;page=2#pid11533805   12楼代码 直接抄

wang-way

1. Public Sub 字典保存单元格区域保留格式的拆分()
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim nwb As Workbook
   
5.     Dim dic As Object
   
6.     Set dic = CreateObject("Scripting.Dictionary")
   
7.     Dim wb As Workbook, sht As Worksheet
   
8.     Set wb = Application.ThisWorkbook
   
9.     Set sht = wb.Worksheets(1)
   
10.     With sht
    
11.         eRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    
12.         Set Rng = .Range("A1").CurrentRegion
    
13.         arr = Rng.Value
    
14.         For i = 2 To UBound(arr)
    
15.             Key = arr(i, 10)
    
16.             If Not dic.Exists(Key) Then
    
17.               Set dic(Key) = Rng.Rows(1)
    
18.             Else
    
19.               Set dic(Key) = Union(dic(Key), Rng.Rows(i))
    
20.             End If
    
21.         Next i
    
22.     End With
    
23.     fd = wb.Path & ""
    
24.     For Each k In dic
    
25.         fp = fd & k & ".xlsx"
    
26.        Set nwb = Workbooks.Add
    
27.         nwb.SaveAs fp
    
28.         dic(k).Copy nwb.Worksheets(1).Range("a1")
    
29.         nwb.Save
    
30.         nwb.Close
    
31.     Next k
    
32.     Application.ScreenUpdating = True
    
33.     Application.DisplayAlerts = True
    
34. End Sub
    

复制代码

feilanga

...............

yeu118

wang-way 发表于 2024-7-1 16:29

这样是保存到哪里呢

Qs18

Sub qs() '2024/7/1
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Dim wb As Workbook, xwb As Workbook, sht As Worksheet, dic As Object, i, k, arr
Set wb = ThisWorkbook: Set sht = wb.Sheets("sheet1")
Set dic = CreateObject("scripting.dictionary")
arr = sht.Range("a1").CurrentRegion.Value
For i = 2 To UBound(arr)
    If Not dic.exists(arr(i, 10)) Then
        dic(arr(i, 10)) = ""
    End If
Next
With sht.Range("a1").CurrentRegion
    For Each k In dic.keys
        .AutoFilter
        .AutoFilter Field:=10, Criteria1:=k

         Set xwb = Workbooks.Add
    .Copy xwb.Sheets(1).Range("a1")
    xwb.SaveAs ThisWorkbook.Path & "\" & k & ".xlsx"
    xwb.Close
Next
.AutoFilter
End With
Application.ScreenUpdating = True: Application.DisplayAlerts = True
Set wb = Nothing: Set xwb = Nothing: Set dic = Nothing: Set sht = Nothing
MsgBox "拆分完成"
End Sub

Qs18

试一下.........

Qs18

试一下.............

wang-way

yeu118 发表于 2024-7-1 16:44
这样是保存到哪里呢

你连抄作业都不会？

peteryhr

yeu118 发表于 2024-7-1 16:44
这样是保存到哪里呢

保存在当前工作簿目录