VBS拆分excel文件并根据第一列中的值进行保存
问题描述:
我有一个包含超过10.000行的excel源文件,其中第一列包含多次相同的值(工厂编号),我需要将该excel文件拆分为多个按工厂编号和日期保存的文件。VBS拆分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
我希望得到任何帮助的代码。先谢谢了。
答
一个新的工作簿的一个新的标准模块中的代码粘贴波纹管
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
+0
感谢Paul的努力。我需要在VBS中有这个...所以我继续尝试。 –
检查此链接每个工厂https://www.extendoffice.com/documents/excel/1174-excel-split-data- into-multiple-worksheets-based-on-column.html – Maddy