VBS拆分excel文件並根據第一列中的值進行保存

Question

我有一個包含超過10.000行的excel源文件，其中第一列包含多次相同的值（工廠編號），我需要將該excel文件拆分爲多個按工廠編號和日期保存的文件。

我能做的是獲得源文件並保存一個新的Excel工作簿的標題，但我無法進入下一步。

要summerize

• 第1行復制到一個新的工作簿
• 選擇，並與第1列相同的值（工廠編號）複製所有行
• 將其粘貼到一個新的工作簿
• 按工廠號和日期保存新的工具書
• 循環直到源文件的最後一行

連接，你會發現我走到這一步，

Set objExcel = CreateObject("Excel.Application") 
Set objWorkbook = objExcel.Workbooks.Open("D:\Original.xlsx") 
Set objWorksheet = objWorkbook.Worksheets("Recipes") 
objExcel.Application.Visible = false 
objExcel.DisplayAlerts = False 
strExcelPath = "D:\Testoutput.xlsx" 
Set objWorkbookNew = objExcel.Workbooks.Add() 
Set objWorksheet2 = objWorkbookNew.Worksheets("Tabelle1") 
objWorksheet.Rows.Range("A1").EntireRow.Copy 
objWorksheet2.Range("A1").PasteSpecial 
objWorkbook.Close 
objExcel.ActiveWorkbook.SaveAs strExcelPath 
objExcel.ActiveWorkbook.Close 
objExcel.Application.Quit 
Set objSheet = Nothing 
Set objWorkbook = Nothing 
Set objExcel = Nothing 

sample

我希望得到任何幫助的代碼。先謝謝了。

Answer 1

一個新的工作簿的一個新的標準模塊中的代碼粘貼波紋管

---

Option Explicit 

Public Sub SplitPlantNumbers() 

    Const SRC = "D:\Original.xlsx" 
    Const DST = "D:\" 
    Const SRC_WS = "Recipes" 
    Const DST_WS = "Tabelle1" 
    Const PN = "Plant Number-" 
    Const DT = "yyyy-mm-dd-hh-mm-ss" 

    Dim wbSrc As Workbook, wsSrc As Worksheet, urSrc As Variant 
    Dim wbDst As Workbook, wsDst As Worksheet, i As Long, d As Object 

    Application.DisplayAlerts = False 
    Application.ScreenUpdating = False 

    Set wbSrc = Workbooks.Open(SRC) 
    If wbSrc Is Nothing Then 
     MsgBox "Invalid source file: " & SRC, , "File Not Found" 
     Exit Sub 
    End If 
    If Not WsExists(wbSrc, SRC_WS) Then 
     MsgBox "Invalid sheet name: " & SRC_WS, , "Src file: " & SRC 
     Exit Sub 
    End If 

    Set wsSrc = wbSrc.Worksheets(SRC_WS) 
    urSrc = wsSrc.UsedRange 

    Set wbDst = ThisWorkbook 
    Set wsDst = GetDstWs(wbDst, DST_WS) 

    If UBound(urSrc) > 1 Then 
     wsSrc.AutoFilterMode = False 
     Set d = CreateObject("Scripting.Dictionary") 

     For i = 2 To UBound(urSrc) 
      d(urSrc(i, 1)) = urSrc(i, 1) '--------------- get uniques 
     Next 

     For i = 1 To d.Count    '--------------- create files 
      With wsSrc.UsedRange 
       .AutoFilter Field:=1, Criteria1:=d(i) 
       .Copy wsDst.Cells(1) 
      End With 
      wbDst.SaveAs Filename:=DST & PN & d(i) & " - " & Format(Now, DT) 
      wsDst.UsedRange.EntireRow.Delete 
     Next 

     wsSrc.AutoFilterMode = False 
     wbSrc.Close False 
    End If 

    Application.DisplayAlerts = True 
    Application.ScreenUpdating = True 
End Sub 

---

Private Function GetDstWs(ByRef wb As Workbook, ByVal wsName As String) As Worksheet 
    Dim ws As Worksheet 

    If Not wb Is Nothing And Len(wsName) > 0 Then 
     If wb.Worksheets.Count > 1 Or _ 
      (wb.Worksheets.Count = 1 And wb.Worksheets(1).Name <> wsName) Then 
      For Each ws In wb.Worksheets 
       If ws.Name = wsName Then 
        ws.Delete 
        Exit For 
       End If 
      Next 
      Set GetDstWs = wb.Worksheets.Add(Before:=wb.Worksheets(1)) 
      GetDstWs.Name = wsName 
      For Each ws In wb.Worksheets 
       If ws.Name <> wsName Then ws.Delete 
      Next 
     Else 
      Set GetDstWs = wb.Worksheets(1) 
     End If 
    End If 
End Function 

Private Function WsExists(ByRef wb As Workbook, ByVal wsName As String) As Boolean 
    Dim ws As Worksheet 

    If Not wb Is Nothing And Len(wsName) > 0 Then 
     For Each ws In wb.Worksheets 
      If ws.Name = wsName Then 
       WsExists = True 
       Exit Function 
      End If 
     Next 
    End If 
End Function 

---

它將在d生成新的文件：像

• Plant Number-1 - 2017-09-25-19-44-33.xlsm
• Plant Number-2 - 2017-09-25-19-44-34.xlsm
• Plant Number-3 - 2017-09-25-19-44-35.xlsm

等，在D:\Original.xlsx