如何將Excel依欄位分類自動儲存並以分類名稱為檔案名稱

imingho

行政人員常常需要匯整各種資料，在整理完後會依照各單位，再把相關的資料copy到Excel，並寄給該單位負責人員，但是Excel在copy時只會copy格式，copy過去時欄寬並不會自動調整，且這樣的copy,paste又是很無聊的事，一不小心還會copy錯，所以我就寫了這一支，自動依照您要分類的欄位，儲存成該檔案名，可以自行在檔案名稱前面及後面加入您想要的字，並自動把每一個欄位調整跟原檔案一樣的欄寬。

檔案名稱:sheetsplit_v2.xlsm

1.執行畫面

說明頁面:
http://272586.blogspot.tw/2008/10/excel_24.html

2015/11/27        加入複製群組功能
2015/4/8        增加使用名稱時自動修正對應檔案(付費功能)費用:300元
2015/1/24        修正頁尾功能位置會亂跳位置的問題
2015/1/19        修正開啟csv時會出現"型態不符合"的錯誤
2015/1/6          修正在Excel 2013按鈕沒有作用
2014/10/29      修正新增"第二個工作表"移到最後
2014/10/28      修正在Excel 2013 "複製第二個工作表名稱"會出現陣列超過索引的問題
2014/4/28        增加設定列印標題
2014/4/24        修正複製頁尾時會多空白列的問題
2014/3/17        加入複製頁尾功能(頁尾資料必需跟原資料中間要有一列空白)
2013/11/1        修正當"第二工作表"在最後一個工作表時會找不到
2013/10/16      新加功能"複製第二個工作表名稱"
2013/9/13        修正儲存時工作表名稱不加入先後置詞,以避免工作表名稱超過31個字
2013/4/19        修正儲存工作表時有無法使用的字元全部用_替換
2012/11/12      修正在excel 2007檢查檔案時會出現錯誤.

excel2003版本,請到
http://discuz.bestdaylong.com/thread-3644-1-1.html


免費版下載:http://download.bestdaylong.com/f20.htm

付費版下載:http://download.bestdaylong.com/f119.htm

lyinghsuan

您好
本巨集是否可加入"完全複製原檔案格式"?
->除了群組, 字型, 公式等原有功能，還可保留篩選, 及列印格式?

謝謝

imingho

2014/4/19加入將工作表中不能用的符號全部轉成_的副程式

Function replace_string(ByVal str As String)
    '將工作表中不能用的符號全部轉成_
    str = Replace(str, "/", "_") '將/換成_
    str = Replace(str, "\", "_") '將\換成_
    str = Replace(str, "?", "_") '將?換成_
    str = Replace(str, "*", "_") '將*換成_
    str = Replace(str, "[", "_") '將[換成_
    str = Replace(str, "]", "_")  '將]換成_
    replace_string = str
End Function

imingho

2013-09-13程式碼:

1. 
   
2. 
   
3. Private Sub cmdMerge_Click()
   
4.     Dim a, b, c As Double '宣告a,b,c為倍精度整數
   
5.    
   
6.     Dim objsheet As Worksheet
   
7.    
   
8.     Dim objtarget As Worksheet
   
9.    
   
10.     Source = Excel.ActiveWorkbook.Name '新檔案視窗編號
    
11.    
    
12.     FilenameExt = Range("b1")   '要處理的檔案副檔名
    
13.    
    
14.     Filename = Range("b2")  '要處理的檔案名稱
    
15.    
    
16.     istxtFile = UCase(Range("b7"))  '是否存為文字檔
    
17.    
    
18.     b = Range("b3").Value
    
19.    
    
20.     first_name = Range("b4").Value
    
21.     last_name = Range("b5").Value
    
22.    
    
23.    
    
24.    
    
25.     Workbooks.Open Filename:=Excel.Workbooks(Source).Path & "\" & Filename & "." & FilenameExt
    
26.    
    
27.     WorkName = Excel.ActiveWorkbook.Name '此檔案名稱
    
28.    
    
29.             
    
30.    
    
31.     '選取工作名稱
    
32.     Set objsheet = Windows(WorkName).ActiveSheet
    
33.    
    
34. 
    
35.     y = 1  '讀取欄位長度
    
36.      
    
37.     Do While True
    
38.         kk = ""
    
39.         For l = 1 To 10
    
40.             For k = 1 To 30
    
41.                 If IsError(objsheet.Cells(k, y + l)) = False Then
    
42.                     kk = kk & objsheet.Cells(k, y + l)
    
43.                 End If
    
44.             Next
    
45.         Next l
    
46.         If kk = "" Then Exit Do
    
47.         y = y + 1
    
48.     Loop
    
49.      
    
50.      
    
51.     '選取目的
    
52.    
    
53.     Windows(WorkName).Activate
    
54.    
    
55.     start_x = Range("b6").Value   '資料開始列數
    
56.    
    
57.     j = start_x
    
58.     a = j
    
59.     oldCell = objsheet.Cells(j, b)
    
60.     While oldCell <> ""
    
61.         If objsheet.Cells(j, b) <> oldCell Then
    
62.             Workbooks.Add   '開新檔
    
63.             NewFile = Excel.ActiveWorkbook.Name '記住新檔案名稱
    
64.             '選取工作名稱
    
65.             Set objtarget = Windows(NewFile).ActiveSheet
    
66.            '選取來源範圍
    
67.             Windows(WorkName).Activate
    
68.             objsheet.Range(objsheet.Cells(1, 1), objsheet.Cells(start_x - 1, y)).Select  'copy標題
    
69.             Selection.Copy
    
70.              'copy
    
71.            Windows(NewFile).Activate
    
72.            objtarget.Cells(1, 1).Select
    
73.             ActiveSheet.Paste
    
74.             
    
75.             Windows(WorkName).Activate
    
76.               
    
77.              objsheet.Range(objsheet.Cells(a, 1), objsheet.Cells(j - 1, y)).Select
    
78.             Selection.Copy
    
79.            Windows(NewFile).Activate
    
80.            objtarget.Cells(start_x, 1).Select
    
81.              ActiveSheet.Paste
    
82.             objtarget.Cells(1, 1).Select
    
83.             
    
84.              If istxtFile <> "Y" Then
    
85.                 '對齊原本欄位
    
86.                  For i = 1 To y
    
87.                      objtarget.Cells(1, i).ColumnWidth = objsheet.Cells(1, i).ColumnWidth
    
88.                  Next
    
89.                  
    
90.                  '對齊原本到列高
    
91.                  '標題列
    
92.                  For i = 1 To start_x - 1
    
93.                      objtarget.Cells(i, 1).RowHeight = objsheet.Cells(i, 1).RowHeight
    
94.                  Next
    
95.                  '資料列
    
96.                  For i = 1 To j - a
    
97.                      objtarget.Cells(start_x - 1 + i, 1).RowHeight = objsheet.Cells(a + i - 1, 1).RowHeight
    
98.                  Next
    
99.             
    
100.                 '跟原本頁面設定一樣
     
101.             
     
102. 
     
103.                 objtarget.PageSetup.LeftHeader = objsheet.PageSetup.LeftHeader
     
104.                 objtarget.PageSetup.CenterHeader = objsheet.PageSetup.CenterHeader
     
105.                 objtarget.PageSetup.RightHeader = objsheet.PageSetup.RightHeader
     
106.                 objtarget.PageSetup.LeftFooter = objsheet.PageSetup.LeftFooter
     
107.                 objtarget.PageSetup.CenterFooter = objsheet.PageSetup.CenterFooter
     
108.                 objtarget.PageSetup.RightFooter = objsheet.PageSetup.RightFooter
     
109.                 objtarget.PageSetup.LeftMargin = objsheet.PageSetup.LeftMargin
     
110.                 objtarget.PageSetup.RightMargin = objsheet.PageSetup.RightMargin
     
111.                 objtarget.PageSetup.TopMargin = objsheet.PageSetup.TopMargin
     
112.                 objtarget.PageSetup.BottomMargin = objsheet.PageSetup.BottomMargin
     
113.                 objtarget.PageSetup.HeaderMargin = objsheet.PageSetup.HeaderMargin
     
114.                 objtarget.PageSetup.FooterMargin = objsheet.PageSetup.FooterMargin
     
115.                 objtarget.PageSetup.PrintHeadings = objsheet.PageSetup.PrintHeadings
     
116.                 objtarget.PageSetup.PrintGridlines = objsheet.PageSetup.PrintGridlines
     
117.                 objtarget.PageSetup.PrintComments = objsheet.PageSetup.PrintComments
     
118.                 objtarget.PageSetup.CenterHorizontally = objsheet.PageSetup.CenterHorizontally
     
119.                 objtarget.PageSetup.CenterVertically = objsheet.PageSetup.CenterVertically
     
120.                 objtarget.PageSetup.Orientation = objsheet.PageSetup.Orientation
     
121.                 objtarget.PageSetup.Draft = objsheet.PageSetup.Draft
     
122.                 objtarget.PageSetup.PaperSize = objsheet.PageSetup.PaperSize
     
123.                 objtarget.PageSetup.FirstPageNumber = objsheet.PageSetup.FirstPageNumber
     
124.                 objtarget.PageSetup.Order = objsheet.PageSetup.Order
     
125.                 objtarget.PageSetup.BlackAndWhite = objsheet.PageSetup.BlackAndWhite
     
126.                 objtarget.PageSetup.Zoom = objsheet.PageSetup.Zoom
     
127.                 objtarget.PageSetup.PrintErrors = objsheet.PageSetup.PrintErrors
     
128.             End If
     
129.             
     
130.             a = j
     
131.             
     
132.             
     
133.             '將活頁改成跟檔案名稱同名
     
134.             objtarget.Name = replace_string(Trim(oldCell))
     
135.                                     
     
136.              '先檢查檔案是否存在
     
137.             Set fs = CreateObject("Scripting.FileSystemObject")
     
138.             
     
139.            
     
140.             While (fs.FileExists(Excel.Workbooks(Source).Path & "\" & first_name & replace_string(Trim(oldCell)) & last_name & "." & FilenameExt))
     
141.                
     
142.                 oldCell = InputBox("檔案重覆,請輸入其它名稱,若輸入*代表離開程式不再繼續", "提醒", oldCell)
     
143.                
     
144.                 If oldCell = "*" Then
     
145.                    Exit Sub
     
146.                 End If
     
147.             
     
148.             Wend
     
149.                                    
     
150.             '另存新檔
     
151.             If oldCell <> "" Then
     
152.                 '另存新檔
     
153.                 If istxtFile <> "Y" Then
     
154.                    '另存新檔
     
155.                    If FilenameExt = "xls" Then
     
156.                        objtarget.SaveAs Excel.Workbooks(Source).Path & "\" & first_name & replace_string(Trim(oldCell)) & last_name & "." & FilenameExt, FileFormat:=xlExcel8
     
157.                        Windows(first_name & replace_string(Trim(oldCell)) & last_name & "." & FilenameExt).Close
     
158.                    Else
     
159.                        objtarget.SaveAs Excel.Workbooks(Source).Path & "\" & first_name & replace_string(Trim(oldCell)) & last_name & "." & FilenameExt
     
160.                        Windows(first_name & replace_string(Trim(oldCell)) & last_name & "." & FilenameExt).Close
     
161.                    End If
     
162.                 Else
     
163.                     
     
164.                     tempfilename = Excel.Workbooks(Source).Path & "\" & first_name & replace_string(Trim(oldCell)) & last_name & ".txt"
     
165. 
     
166.                     ActiveWorkbook.SaveAs Filename:= _
     
167.                     tempfilename, FileFormat:=xlText, _
     
168.                     CreateBackup:=False
     
169.                     
     
170.                     Excel.Application.DisplayAlerts = False '將Excel警告關閉
     
171.                     Windows(first_name & replace_string(Trim(oldCell)) & last_name & ".txt").Close
     
172.                     Excel.Application.DisplayAlerts = True '將Excel警告打開
     
173.                 End If
     
174.             End If
     
175.         End If
     
176.            '選取來源範圍
     
177.         Windows(WorkName).Activate
     
178.         oldCell = objsheet.Cells(j, b)
     
179.         j = j + 1
     
180.     Wend
     
181.    
     
182. 
     
183.       
     
184.    
     
185.     '將來源檔案關閉
     
186.      Windows(WorkName).Close
     
187.      
     
188.      MsgBox "處理完畢!!", vbOKOnly, "彰化一整天的blog"
     
189. 
     
190. 
     
191. End Sub
     
192. 
     
193. Function replace_string(ByVal str As String)
     
194.     '將工作表中不能用的符號全部轉成_
     
195.     str = Replace(str, "/", "_") '將/換成_
     
196.     str = Replace(str, "\", "_") '將\換成_
     
197.     str = Replace(str, "?", "_") '將?換成_
     
198.     str = Replace(str, "*", "_") '將*換成_
     
199.     str = Replace(str, "[", "_") '將[換成_
     
200.     str = Replace(str, "]", "_")  '將]換成_
     
201.     replace_string = str
     
202. End Function
     

複製代碼

wendykuo

Dear 大大,

很感謝您的小程式,幫了我不少忙,目前剛好看到您寫的這個vba,很適合我現在的狀況,只是,是否能加
添除分拆工作表另存檔,再加上存檔時,另加1個工作表,說明如下,另附上測試檔案1份,謝謝您。
說明:
excel活頁簿裡有2個(a,b)工作表,1個a工作表要拆分(可依欄位),另1個b不用拆分,但最後新檔存的部分,
仍會有2個(a,b)工作表。

imingho

wendykuo 發表於 2013-10-11 11:13
Dear 大大,

很感謝您的小程式,幫了我不少忙,目前剛好看到您寫的這個vba,很適合我現在的狀況,只是,是否能加 ...

您好,
     我沒看到您的附檔,麻煩您再上傳一次，還有可以請您用圖說明處理前跟處理後嗎?文字描述是很難瞭解您的問題.

wendykuo

Dear 大大,
不好意思,檔案如附,謝謝您

wendykuo

我還是畫了個示意圖(汗...),希望可以再說明更清楚我的想法,若還有不盡之處,再告訴我,
我再看看如何表達我的問題,麻煩您了,謝謝

imingho

wendykuo 發表於 2013-10-11 12:01
我還是畫了個示意圖(汗...),希望可以再說明更清楚我的想法,若還有不盡之處,再告訴我,
我再看看如何表達我的 ...

我大概瞭解您的需求，這個修改需要一點時間，我改好再上傳給您測試。

imingho

wendykuo 發表於 2013-10-11 12:01
我還是畫了個示意圖(汗...),希望可以再說明更清楚我的想法,若還有不盡之處,再告訴我,
我再看看如何表達我的 ...

您好,
      您要的功能己加上.麻煩您重新下載即可.
2013/10/16        新加功能"複製第二個工作表名稱"

wendykuo

Dear 大大,

您真的太神了！謝謝您的幫忙！