彰化一整天的論壇

 找回密碼
 立即註冊
查看: 3376|回復: 2

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

[複製鏈接]
發表於 2012-11-12 10:00:22 | 顯示全部樓層 |閱讀模式
本帖最後由 imingho 於 2015-3-24 13:14 編輯

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

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

2013/8/15        將入多欄位比對
2010/11/27        將修改文字檔時會出現的警告關閉
2010/11/25        新增是否存成文字檔

檔案名稱:sheetsplit_v2.xls測試資料檔案:testsplit.xls

免費下載: http://download.bestdaylong.com/f17.htm
excel2007版本,請到
http://discuz.bestdaylong.com/thread-3646-1-1.html

sheetsplit_v2.xls

687 KB, 下載次數: 11

售價: 2 金錢  [記錄]

sheetsplit_v2.xls

testsplit.xls

19 KB, 下載次數: 4

售價: 1 金錢  [記錄]

測試資料

回復

使用道具 舉報

 樓主| 發表於 2013-8-15 17:14:35 | 顯示全部樓層
多欄位程式碼 2013/8/15修改


  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.     strfields = Split(b, ",")  '將比對欄位變成陣列
  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.     For k = 0 To UBound(strfields)
  57.         If k = 0 Then
  58.             oldCell = Trim(objsheet.Range(strfields(k) & j))
  59.         Else
  60.             If Trim(objsheet.Range(strfields(k) & j)) <> "" Then
  61.                 oldCell = oldCell & "_" & Trim(objsheet.Range(strfields(k) & j))
  62.             End If
  63.         End If
  64.     Next
  65.     While oldCell <> ""
  66.         '目前的讀到的值
  67.         For k = 0 To UBound(strfields)
  68.             If k = 0 Then
  69.                 readCell = Trim(objsheet.Range(strfields(k) & j))
  70.             Else
  71.                 If Trim(objsheet.Range(strfields(k) & j)) <> "" Then
  72.                    readCell = readCell & "_" & Trim(objsheet.Range(strfields(k) & j))
  73.                 End If
  74.             End If
  75.         Next

  76.    
  77.    
  78.         If readCell <> oldCell Then
  79.             Workbooks.Add   '開新檔
  80.             NewFile = Excel.ActiveWorkbook.Name '記住新檔案名稱
  81.             '選取工作名稱
  82.             Set objtarget = Windows(NewFile).ActiveSheet
  83.            '選取來源範圍
  84.             Windows(WorkName).Activate
  85.             objsheet.Range(objsheet.Cells(1, 1), objsheet.Cells(start_x - 1, y)).Select  'copy標題
  86.             Selection.Copy
  87.              'copy
  88.            Windows(NewFile).Activate
  89.            objtarget.Cells(1, 1).Select
  90.             ActiveSheet.Paste
  91.             
  92.             Windows(WorkName).Activate
  93.               
  94.              objsheet.Range(objsheet.Cells(a, 1), objsheet.Cells(j - 1, y)).Select
  95.             Selection.Copy
  96.            Windows(NewFile).Activate
  97.            objtarget.Cells(start_x, 1).Select
  98.              ActiveSheet.Paste
  99.             objtarget.Cells(1, 1).Select
  100.             
  101.              If istxtFile <> "Y" Then
  102.                 '對齊原本欄位
  103.                  For i = 1 To y
  104.                      objtarget.Cells(1, i).ColumnWidth = objsheet.Cells(1, i).ColumnWidth
  105.                  Next
  106.                  
  107.                  '對齊原本到列高
  108.                  '標題列
  109.                  For i = 1 To start_x - 1
  110.                      objtarget.Cells(i, 1).RowHeight = objsheet.Cells(i, 1).RowHeight
  111.                  Next
  112.                  '資料列
  113.                  For i = 1 To j - a
  114.                      objtarget.Cells(start_x - 1 + i, 1).RowHeight = objsheet.Cells(a + i - 1, 1).RowHeight
  115.                  Next
  116.             
  117.                 '跟原本頁面設定一樣
  118.             

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

  175.                     ActiveWorkbook.SaveAs Filename:= _
  176.                     tempfilename, FileFormat:=xlText, _
  177.                     CreateBackup:=False
  178.                     
  179.                     Excel.Application.DisplayAlerts = False '將Excel警告關閉
  180.                     Windows(first_name & Trim(oldCell) & last_name & ".txt").Close
  181.                     Excel.Application.DisplayAlerts = True '將Excel警告打開
  182.                 End If
  183.             End If
  184.         End If
  185.            '選取來源範圍
  186.         Windows(WorkName).Activate
  187.         For k = 0 To UBound(strfields)
  188.             If k = 0 Then
  189.                 oldCell = Trim(objsheet.Range(strfields(k) & j))
  190.             Else
  191.                 If Trim(objsheet.Range(strfields(k) & j)) <> "" Then
  192.                    oldCell = oldCell & "_" & Trim(objsheet.Range(strfields(k) & j))
  193.                 End If
  194.             End If
  195.         Next
  196.         j = j + 1
  197.     Wend
  198.    

  199.       
  200.    
  201.     '將來源檔案關閉
  202.      Windows(WorkName).Close
  203.      
  204.      MsgBox "處理完畢!!", vbOKOnly, "彰化一整天的blog"


  205. End Sub
複製代碼
回復 支持 反對

使用道具 舉報

 樓主| 發表於 2013-8-15 23:03:20 | 顯示全部樓層
  1. 單一欄位程式碼


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

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

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

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

  172.       
  173.    
  174.     '將來源檔案關閉
  175.      Windows(WorkName).Close
  176.      
  177.      MsgBox "處理完畢!!", vbOKOnly, "彰化一整天的blog"


  178. End Sub
複製代碼
回復 支持 反對

使用道具 舉報

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

本版積分規則

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

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

GMT+8, 2019-10-15 17:43 , Processed in 0.131354 second(s), 22 queries .

Powered by Discuz! X3.2

© 2001-2013 Comsenz Inc.

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