分別單獨儲存成EXCEL檔

koala2099

請教會的大大幫個忙~:dizzy:
統計201204是一份總表
01、02、04.....分別代表一個倉庫
每個倉庫資料量不同(皆有上千筆)
其中的倉庫也有可能會無資料
需依倉庫分別單獨儲存成EXCEL檔(只需該倉庫的資料)
當月有幾個倉庫就會有幾個EXCEL檔

hugh0620

回復 1# koala2099

1. Private Sub CommandButton1_Click()
   
2. '======篩選有幾個倉庫===========
   
3.     Sheet1.Range("B2:B65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet1.Range( _
   
4.         "P2"), Unique:=True
   
5.         
   
6. A = Sheet1.Range("P65536").End(xlUp).Row       '共有幾個倉庫
   
7. B = Sheet1.Range("C65536").End(xlUp).Row       '共有多少筆資料要被執行
   
8. With Application.FileDialog(msoFileDialogFolderPicker)
   
9.     If .Show = 0 Then Exit Sub
   
10.     patch = .SelectedItems(1)
    
11.     Application.DefaultFilePath = patch
    
12.     If .ButtonName = "確定" Then
    
13.         For I = 2 To A
    
14.             Workbooks.Add
    
15.             ActiveWorkbook.Sheets(1).Name = Sheet1.Range("P" & I)
    
16.             With ActiveWorkbook
    
17.             Sheet1.Range("A1:J1").Copy .Sheets(1).Range("A1")
    
18.             For J = 2 To B
    
19.                 If Sheet1.Range("P" & I) = Sheet1.Range("B" & J) Then
    
20.                    .Sheets(1).Range("A" & 2 + N) = Sheet1.Range("A" & J)
    
21.                    .Sheets(1).Range("B" & 2 + N) = Sheet1.Range("B" & J)
    
22.                    .Sheets(1).Range("C" & 2 + N) = Sheet1.Range("C" & J)
    
23.                    .Sheets(1).Range("D" & 2 + N) = Sheet1.Range("D" & J)
    
24.                    .Sheets(1).Range("E" & 2 + N) = Sheet1.Range("E" & J)
    
25.                    .Sheets(1).Range("F" & 2 + N) = Sheet1.Range("F" & J)
    
26.                    .Sheets(1).Range("G" & 2 + N) = Sheet1.Range("G" & J)
    
27.                    .Sheets(1).Range("H" & 2 + N) = Sheet1.Range("H" & J)
    
28.                    .Sheets(1).Range("I" & 2 + N) = Sheet1.Range("I" & J)
    
29.                    .Sheets(1).Range("J" & 2 + N) = Sheet1.Range("J" & J)
    
30.                    N = N + 1
    
31.                 End If
    
32.             Next
    
33.             .SaveAs Application.DefaultFilePath & "\" & Sheet1.Range("P" & I)
    
34.             .Close
    
35.             End With
    
36.             N = 0
    
37.         Next
    
38.     End If
    
39. End With
    
40. Sheet1.Range("P:P").Delete
    
41. ActiveWorkbook.Save
    
42. End Sub

複製代碼

register313

回復 1# koala2099

1. Sub NewWb()
   
2.   Set d = CreateObject("Scripting.Dictionary")
   
3.   Application.ScreenUpdating = False
   
4.   Application.DisplayAlerts = False
   
5.   Ar = Sheets("倉庫").[A1].CurrentRegion
   
6.   For k = 2 To UBound(Ar)
   
7.       d(Ar(k, 2)) = ""
   
8.   Next
   
9.   For Each dx In d
   
10.       [A1].AutoFilter Field:=2, Criteria1:=dx
    
11.       [A1].CurrentRegion.Copy
    
12.       Workbooks.Add
    
13.       With ActiveWorkbook
    
14.           .ActiveSheet.Paste
    
15.           .ActiveSheet.Name = dx
    
16.           .SaveAs ThisWorkbook.Path & "\" & dx & ".xls"
    
17.           .Close
    
18.       End With
    
19.   Next
    
20.   [A1].AutoFilter
    
21.   Application.DisplayAlerts = True
    
22.   Application.ScreenUpdating = True
    
23.   MsgBox "工作表依條件另存活頁簿,執行完畢!"
    
24. End Sub

複製代碼

GBKEE

回復 1# koala2099

1. Option Explicit
   
2. Sub Ex()  '進階篩選 + 自動篩選
   
3.     Dim Rng As Range, xi As Integer
   
4.      Application.ScreenUpdating = False
   
5.      With ActiveSheet                     '作用中的工作表
   
6.         '使用 AdvancedFilter 進階篩選 篩選不重復的資料 取得有料的倉庫------------
   
7.         '參數 Action: =xlFilterCopy (複製在別的範圍)
   
8.         '參數 CriteriaRange (準則範圍) ':=.Cells(1, .Columns.Count - 1).Resize(2)  準則範圍。如果省略此引數則無準則。
   
9.         '準則範圍 的條件為空白為所有篩選的資料
   
10.         '參數 CopyToRange  選擇性的 Variant。如果 Action 為 xlFilterCopy，此引數指定被複製列的目標範圍。否則忽略此引數。
    
11.         '參數 Unique     選擇性的 Variant。若為 True，則僅篩選唯一的記錄；若為 False，則篩選出所有符合準則的記錄。預設值為 False。
    
12.         .Cells(1, .Columns.Count - 1) = "aaa"             '
    
13.         .Range("B:B").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Cells(1, .Columns.Count - 1).Resize(2), _
    
14.          CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
    
15.          '------------------------------------------------------------------
    
16.          Set Rng = .Columns(.Columns.Count).SpecialCells(xlCellTypeConstants) '倉庫別的範圍
    
17.          .AutoFilterMode = False                                              '取消 這工作表的自動篩選
    
18.          For xi = 2 To Rng.Count                                              '倉庫的迴圈
    
19.             .[A1].AutoFilter Field:=2, Criteria1:=Rng(xi)                     '自動篩選  第2欄 中  指定 倉庫
    
20.             .[A1].CurrentRegion.Copy                                          '複製自動篩選到的資料
    
21.             With Workbooks.Add(1)                                             '新開活頁簿 工作表1張
    
22.                 .Sheets(1).Paste                                              '第1張工作表 貼上資料
    
23.                 .Sheets(1).Name = Rng(xi)                                     '第1張工作表 命名:倉庫別
    
24.                 .SaveAs ThisWorkbook.Path & "\" & Rng(xi) & ".xls"            '新開活頁簿  存檔
    
25.                 .Close                                                        '新開活頁簿  關閉
    
26.             End With
    
27.         Next
    
28.         .Cells(1, .Columns.Count - 1).Resize(, 2).EntireColumn.Clear          '清除進階篩選的資料
    
29.     End With
    
30.     Application.ScreenUpdating = True
    
31. End Sub

複製代碼

koala2099

回復 4# GBKEE
SORRY~忙於工作
過了這麼多天才上來回覆
剛試了完成符合需求
感謝大大的協助0.0端午節佳節快樂

user999

回復 3# register313


   
能順道請教一下,如果執行完後所產生的excel檔,能否再執行一次時 ,在各自excel工作簿新增一個sheet,而不是蓋過原execl檔案
謝謝!