彰化一整天的論壇

 找回密碼
 立即註冊
搜索
查看: 10104|回復: 49

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

[複製鏈接]
發表於 2012-11-12 10:05:48 | 顯示全部樓層 |閱讀模式
本帖最後由 imingho 於 2015-11-27 11:35 編輯

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

檔案名稱:
sheetsplit_v2.xlsm



excel2007_sheetsplit_01.png

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











sheetsplit_v2.xlsm

35.25 KB, 下載次數: 71

售價: 2 金錢  [記錄]

sheetsplit_v2.xlsm

回復

使用道具 舉報

 樓主| 發表於 2013-4-19 10:19:22 | 顯示全部樓層
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
回復 支持 反對

使用道具 舉報

 樓主| 發表於 2013-9-13 13:43:09 | 顯示全部樓層
2013-09-13程式碼:


  1. Private Sub cmdMerge_Click()
  2.     Dim a, b, c As Double '宣告a,b,c為倍精度整數
  3.    
  4.     Dim objsheet As Worksheet
  5.    
  6.     Dim objtarget As Worksheet
  7.    
  8.     Source = Excel.ActiveWorkbook.Name '新檔案視窗編號
  9.    
  10.     FilenameExt = Range("b1")   '要處理的檔案副檔名
  11.    
  12.     Filename = Range("b2")  '要處理的檔案名稱
  13.    
  14.     istxtFile = UCase(Range("b7"))  '是否存為文字檔
  15.    
  16.     b = Range("b3").Value
  17.    
  18.     first_name = Range("b4").Value
  19.     last_name = Range("b5").Value
  20.    
  21.    
  22.    
  23.     Workbooks.Open Filename:=Excel.Workbooks(Source).Path & "\" & Filename & "." & FilenameExt
  24.    
  25.     WorkName = Excel.ActiveWorkbook.Name '此檔案名稱
  26.    
  27.             
  28.    
  29.     '選取工作名稱
  30.     Set objsheet = Windows(WorkName).ActiveSheet
  31.    

  32.     y = 1  '讀取欄位長度
  33.      
  34.     Do While True
  35.         kk = ""
  36.         For l = 1 To 10
  37.             For k = 1 To 30
  38.                 If IsError(objsheet.Cells(k, y + l)) = False Then
  39.                     kk = kk & objsheet.Cells(k, y + l)
  40.                 End If
  41.             Next
  42.         Next l
  43.         If kk = "" Then Exit Do
  44.         y = y + 1
  45.     Loop
  46.      
  47.      
  48.     '選取目的
  49.    
  50.     Windows(WorkName).Activate
  51.    
  52.     start_x = Range("b6").Value   '資料開始列數
  53.    
  54.     j = start_x
  55.     a = j
  56.     oldCell = objsheet.Cells(j, b)
  57.     While oldCell <> ""
  58.         If objsheet.Cells(j, b) <> oldCell Then
  59.             Workbooks.Add   '開新檔
  60.             NewFile = Excel.ActiveWorkbook.Name '記住新檔案名稱
  61.             '選取工作名稱
  62.             Set objtarget = Windows(NewFile).ActiveSheet
  63.            '選取來源範圍
  64.             Windows(WorkName).Activate
  65.             objsheet.Range(objsheet.Cells(1, 1), objsheet.Cells(start_x - 1, y)).Select  'copy標題
  66.             Selection.Copy
  67.              'copy
  68.            Windows(NewFile).Activate
  69.            objtarget.Cells(1, 1).Select
  70.             ActiveSheet.Paste
  71.             
  72.             Windows(WorkName).Activate
  73.               
  74.              objsheet.Range(objsheet.Cells(a, 1), objsheet.Cells(j - 1, y)).Select
  75.             Selection.Copy
  76.            Windows(NewFile).Activate
  77.            objtarget.Cells(start_x, 1).Select
  78.              ActiveSheet.Paste
  79.             objtarget.Cells(1, 1).Select
  80.             
  81.              If istxtFile <> "Y" Then
  82.                 '對齊原本欄位
  83.                  For i = 1 To y
  84.                      objtarget.Cells(1, i).ColumnWidth = objsheet.Cells(1, i).ColumnWidth
  85.                  Next
  86.                  
  87.                  '對齊原本到列高
  88.                  '標題列
  89.                  For i = 1 To start_x - 1
  90.                      objtarget.Cells(i, 1).RowHeight = objsheet.Cells(i, 1).RowHeight
  91.                  Next
  92.                  '資料列
  93.                  For i = 1 To j - a
  94.                      objtarget.Cells(start_x - 1 + i, 1).RowHeight = objsheet.Cells(a + i - 1, 1).RowHeight
  95.                  Next
  96.             
  97.                 '跟原本頁面設定一樣
  98.             

  99.                 objtarget.PageSetup.LeftHeader = objsheet.PageSetup.LeftHeader
  100.                 objtarget.PageSetup.CenterHeader = objsheet.PageSetup.CenterHeader
  101.                 objtarget.PageSetup.RightHeader = objsheet.PageSetup.RightHeader
  102.                 objtarget.PageSetup.LeftFooter = objsheet.PageSetup.LeftFooter
  103.                 objtarget.PageSetup.CenterFooter = objsheet.PageSetup.CenterFooter
  104.                 objtarget.PageSetup.RightFooter = objsheet.PageSetup.RightFooter
  105.                 objtarget.PageSetup.LeftMargin = objsheet.PageSetup.LeftMargin
  106.                 objtarget.PageSetup.RightMargin = objsheet.PageSetup.RightMargin
  107.                 objtarget.PageSetup.TopMargin = objsheet.PageSetup.TopMargin
  108.                 objtarget.PageSetup.BottomMargin = objsheet.PageSetup.BottomMargin
  109.                 objtarget.PageSetup.HeaderMargin = objsheet.PageSetup.HeaderMargin
  110.                 objtarget.PageSetup.FooterMargin = objsheet.PageSetup.FooterMargin
  111.                 objtarget.PageSetup.PrintHeadings = objsheet.PageSetup.PrintHeadings
  112.                 objtarget.PageSetup.PrintGridlines = objsheet.PageSetup.PrintGridlines
  113.                 objtarget.PageSetup.PrintComments = objsheet.PageSetup.PrintComments
  114.                 objtarget.PageSetup.CenterHorizontally = objsheet.PageSetup.CenterHorizontally
  115.                 objtarget.PageSetup.CenterVertically = objsheet.PageSetup.CenterVertically
  116.                 objtarget.PageSetup.Orientation = objsheet.PageSetup.Orientation
  117.                 objtarget.PageSetup.Draft = objsheet.PageSetup.Draft
  118.                 objtarget.PageSetup.PaperSize = objsheet.PageSetup.PaperSize
  119.                 objtarget.PageSetup.FirstPageNumber = objsheet.PageSetup.FirstPageNumber
  120.                 objtarget.PageSetup.Order = objsheet.PageSetup.Order
  121.                 objtarget.PageSetup.BlackAndWhite = objsheet.PageSetup.BlackAndWhite
  122.                 objtarget.PageSetup.Zoom = objsheet.PageSetup.Zoom
  123.                 objtarget.PageSetup.PrintErrors = objsheet.PageSetup.PrintErrors
  124.             End If
  125.             
  126.             a = j
  127.             
  128.             
  129.             '將活頁改成跟檔案名稱同名
  130.             objtarget.Name = replace_string(Trim(oldCell))
  131.                                     
  132.              '先檢查檔案是否存在
  133.             Set fs = CreateObject("Scripting.FileSystemObject")
  134.             
  135.            
  136.             While (fs.FileExists(Excel.Workbooks(Source).Path & "\" & first_name & replace_string(Trim(oldCell)) & last_name & "." & FilenameExt))
  137.                
  138.                 oldCell = InputBox("檔案重覆,請輸入其它名稱,若輸入*代表離開程式不再繼續", "提醒", oldCell)
  139.                
  140.                 If oldCell = "*" Then
  141.                    Exit Sub
  142.                 End If
  143.             
  144.             Wend
  145.                                    
  146.             '另存新檔
  147.             If oldCell <> "" Then
  148.                 '另存新檔
  149.                 If istxtFile <> "Y" Then
  150.                    '另存新檔
  151.                    If FilenameExt = "xls" Then
  152.                        objtarget.SaveAs Excel.Workbooks(Source).Path & "\" & first_name & replace_string(Trim(oldCell)) & last_name & "." & FilenameExt, FileFormat:=xlExcel8
  153.                        Windows(first_name & replace_string(Trim(oldCell)) & last_name & "." & FilenameExt).Close
  154.                    Else
  155.                        objtarget.SaveAs Excel.Workbooks(Source).Path & "\" & first_name & replace_string(Trim(oldCell)) & last_name & "." & FilenameExt
  156.                        Windows(first_name & replace_string(Trim(oldCell)) & last_name & "." & FilenameExt).Close
  157.                    End If
  158.                 Else
  159.                     
  160.                     tempfilename = Excel.Workbooks(Source).Path & "\" & first_name & replace_string(Trim(oldCell)) & last_name & ".txt"

  161.                     ActiveWorkbook.SaveAs Filename:= _
  162.                     tempfilename, FileFormat:=xlText, _
  163.                     CreateBackup:=False
  164.                     
  165.                     Excel.Application.DisplayAlerts = False '將Excel警告關閉
  166.                     Windows(first_name & replace_string(Trim(oldCell)) & last_name & ".txt").Close
  167.                     Excel.Application.DisplayAlerts = True '將Excel警告打開
  168.                 End If
  169.             End If
  170.         End If
  171.            '選取來源範圍
  172.         Windows(WorkName).Activate
  173.         oldCell = objsheet.Cells(j, b)
  174.         j = j + 1
  175.     Wend
  176.    

  177.       
  178.    
  179.     '將來源檔案關閉
  180.      Windows(WorkName).Close
  181.      
  182.      MsgBox "處理完畢!!", vbOKOnly, "彰化一整天的blog"


  183. End Sub

  184. Function replace_string(ByVal str As String)
  185.     '將工作表中不能用的符號全部轉成_
  186.     str = Replace(str, "/", "_") '將/換成_
  187.     str = Replace(str, "\", "_") '將\換成_
  188.     str = Replace(str, "?", "_") '將?換成_
  189.     str = Replace(str, "*", "_") '將*換成_
  190.     str = Replace(str, "[", "_") '將[換成_
  191.     str = Replace(str, "]", "_")  '將]換成_
  192.     replace_string = str
  193. End Function
複製代碼
回復 支持 反對

使用道具 舉報

發表於 2013-10-11 11:13:33 | 顯示全部樓層
Dear 大大,

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

使用道具 舉報

 樓主| 發表於 2013-10-11 11:21:53 | 顯示全部樓層
本帖最後由 imingho 於 2013-10-11 11:23 編輯
wendykuo 發表於 2013-10-11 11:13
Dear 大大,

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

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

使用道具 舉報

發表於 2013-10-11 11:28:38 | 顯示全部樓層
Dear 大大,
不好意思,檔案如附,謝謝您

分別存檔.rar

13.73 KB, 下載次數: 302

回復 支持 反對

使用道具 舉報

發表於 2013-10-11 12:01:33 | 顯示全部樓層
我還是畫了個示意圖(汗...),希望可以再說明更清楚我的想法,若還有不盡之處,再告訴我,
我再看看如何表達我的問題,麻煩您了,謝謝

圖示.docx

31 KB, 下載次數: 290

回復 支持 反對

使用道具 舉報

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

我大概瞭解您的需求,這個修改需要一點時間,我改好再上傳給您測試。
回復 支持 反對

使用道具 舉報

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

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

使用道具 舉報

發表於 2013-10-16 21:14:24 | 顯示全部樓層
Dear 大大,

您真的太神了!謝謝您的幫忙!
回復 支持 反對

使用道具 舉報

您需要登錄後才可以回帖 登錄 | 立即註冊

本版積分規則

 ㄚ母滴雞湯
 員林香純滴雞精

Archiver|手機版|小黑屋|彰化一整天的論壇(Excel,Office)  |网站地图

GMT+8, 2017-12-11 10:16 , Processed in 0.041470 second(s), 15 queries , Apc On.

Powered by Discuz! X3.2

© 2001-2013 Comsenz Inc.

快速回復 返回頂部 返回列表