koala2099

帖子: 58
主題: 21
精華: 0
積分: 97
點名: 0
作業系統: win8
軟體版本: office2010
閱讀權限: 20
性別: 女
註冊時間: 2011-2-28
最後登錄: 2024-10-3

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 2012-6-15 00:19 | 只看該作者

分別單獨儲存成EXCEL檔

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

新資料夾.rar (21.56 KB)

樓主熱帖

hugh0620

　暱稱: VBA向前衝

高中生 Rank: 3 Rank: 3

帖子: 559
主題: 58
精華: 0
積分: 626
點名: 0
作業系統: win8
軟體版本: office2013
閱讀權限: 50
性別: 男
來自: TW
註冊時間: 2010-11-22
最後登錄: 2024-6-14

2^#

發表於 2012-6-15 10:00 | 只看該作者

回復 1# koala2099

Private Sub CommandButton1_Click()
'======篩選有幾個倉庫===========
Sheet1.Range("B2:B65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet1.Range( _
"P2"), Unique:=True
A = Sheet1.Range("P65536").End(xlUp).Row '共有幾個倉庫
B = Sheet1.Range("C65536").End(xlUp).Row '共有多少筆資料要被執行
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = 0 Then Exit Sub
patch = .SelectedItems(1)
Application.DefaultFilePath = patch
If .ButtonName = "確定" Then
For I = 2 To A
Workbooks.Add
ActiveWorkbook.Sheets(1).Name = Sheet1.Range("P" & I)
With ActiveWorkbook
Sheet1.Range("A1:J1").Copy .Sheets(1).Range("A1")
For J = 2 To B
If Sheet1.Range("P" & I) = Sheet1.Range("B" & J) Then
.Sheets(1).Range("A" & 2 + N) = Sheet1.Range("A" & J)
.Sheets(1).Range("B" & 2 + N) = Sheet1.Range("B" & J)
.Sheets(1).Range("C" & 2 + N) = Sheet1.Range("C" & J)
.Sheets(1).Range("D" & 2 + N) = Sheet1.Range("D" & J)
.Sheets(1).Range("E" & 2 + N) = Sheet1.Range("E" & J)
.Sheets(1).Range("F" & 2 + N) = Sheet1.Range("F" & J)
.Sheets(1).Range("G" & 2 + N) = Sheet1.Range("G" & J)
.Sheets(1).Range("H" & 2 + N) = Sheet1.Range("H" & J)
.Sheets(1).Range("I" & 2 + N) = Sheet1.Range("I" & J)
.Sheets(1).Range("J" & 2 + N) = Sheet1.Range("J" & J)
N = N + 1
End If
Next
.SaveAs Application.DefaultFilePath & "\" & Sheet1.Range("P" & I)
.Close
End With
N = 0
Next
End If
End With
Sheet1.Range("P:P").Delete
ActiveWorkbook.Save
End Sub

複製代碼

學習才能提升自己

TOP

register313

　頭銜: 麻辣路人甲

大學生 Rank: 4

帖子: 967
主題: 0
精華: 0
積分: 1001
點名: 0
作業系統: WIN XP
軟體版本: OFFICE 2003
閱讀權限: 50
性別: 男
來自: 台北
註冊時間: 2010-11-29
最後登錄: 2022-5-17

2012龍年全勤獎章熱烈參與勳章

3^#

發表於 2012-6-16 18:45 | 只看該作者

回復 1# koala2099

Sub NewWb()
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Ar = Sheets("倉庫").[A1].CurrentRegion
For k = 2 To UBound(Ar)
d(Ar(k, 2)) = ""
Next
For Each dx In d
[A1].AutoFilter Field:=2, Criteria1:=dx
[A1].CurrentRegion.Copy
Workbooks.Add
With ActiveWorkbook
.ActiveSheet.Paste
.ActiveSheet.Name = dx
.SaveAs ThisWorkbook.Path & "\" & dx & ".xls"
.Close
End With
Next
[A1].AutoFilter
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "工作表依條件另存活頁簿,執行完畢!"
End Sub

複製代碼

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

4^#

發表於 2012-6-17 11:05 | 只看該作者

回復 1# koala2099

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