如果输出工作簿名称已存在则合并
Merge if output workbook name already exists
我在一个文件夹下有大约 100 个 .xls
文件,我有一个宏脚本来遍历每个文件以进行一些数据处理。 objective是将每个工作簿拆分为三个,名称分别为N1
、N2
、N3
。到目前为止,我的 SplitData
宏工作正常,但我对提取的工作簿有疑问。
我想将新提取的三个工作簿合并到已经存在的工作簿中,而不是每次都收到像 "File N1 already exists." 这样的警报。我想知道在 VBA 脚本中是否有办法实现这一点?或任何其他解决方案?
谢谢!
这是我循环遍历文件夹的代码:
Sub OpenFiles()
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
On Error Resume Next
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
xFile = Dir(xStrPath & "\*.xls")
Do While xFile <> ""
Call SplitData
Loop
End Sub
这是 SplitData 宏:
Sub SplitData()
' 1. Fill every cells in merged columns for future steps
Dim cell As Range, joinedCells As Range
For Each cell In Range("E4:I60")
If cell.MergeCells Then
Set joinedCells = cell.MergeArea
cell.MergeCells = False
joinedCells.Value = cell.Value
End If
Next
' 2. Split original sheet into three based on one col value
' loop through selected column to check if has different values
Const NameCol = "B"
Const HeaderRow = 3
Const FirstRow = 4
Dim SrcSheet As Worksheet
Dim TrgSheet As Worksheet
Dim SrcRow As Long
Dim LastRow As Long
Dim TrgRow As Long
Dim Student As String
Application.ScreenUpdating = False
Set SrcSheet = ActiveSheet
LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
Student = SrcSheet.Cells(SrcRow, NameCol).Value
Set TrgSheet = Nothing
On Error Resume Next
Set TrgSheet = Worksheets(Student)
On Error GoTo 0
If TrgSheet Is Nothing Then
Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
TrgSheet.Name = Student
SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
End If
TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
Next SrcRow
Application.ScreenUpdating = True
' 3. Extract three new worksheets into three workbooks
Dim Pointer As Long
Set MainWorkBook = ActiveWorkbook
Range("E4").Value = MainWorkBook.Sheets.Count
Application.ScreenUpdating = False 'enhance the performance
For Pointer = 2 To MainWorkBook.Sheets.Count
Set NewWorkbook = Workbooks.Add
MainWorkBook.Sheets(Pointer).Copy After:=NewWorkbook.Sheets(1)
Application.DisplayAlerts = False
NewWorkbook.Sheets(1).Delete
Application.DisplayAlerts = True
With NewWorkbook
.SaveAs Filename:="D:\***\Inventory\" & MainWorkBook.Sheets(Pointer).Name & ".xls"
End With
NewWorkbook.Close SaveChanges:=True
Next Pointer
Application.ScreenUpdating = True
End Sub
假设您已经在脚本中的路径中设置了所需的文件名,请更改
Application.DisplayAlerts = True
到
Application.DisplayAlerts = false
以避免收到覆盖警告。
保存后将其改回 true 以防止其他地方出现问题。
希望对您有所帮助
我在一个文件夹下有大约 100 个 .xls
文件,我有一个宏脚本来遍历每个文件以进行一些数据处理。 objective是将每个工作簿拆分为三个,名称分别为N1
、N2
、N3
。到目前为止,我的 SplitData
宏工作正常,但我对提取的工作簿有疑问。
我想将新提取的三个工作簿合并到已经存在的工作簿中,而不是每次都收到像 "File N1 already exists." 这样的警报。我想知道在 VBA 脚本中是否有办法实现这一点?或任何其他解决方案?
谢谢!
这是我循环遍历文件夹的代码:
Sub OpenFiles()
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
On Error Resume Next
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
xFile = Dir(xStrPath & "\*.xls")
Do While xFile <> ""
Call SplitData
Loop
End Sub
这是 SplitData 宏:
Sub SplitData()
' 1. Fill every cells in merged columns for future steps
Dim cell As Range, joinedCells As Range
For Each cell In Range("E4:I60")
If cell.MergeCells Then
Set joinedCells = cell.MergeArea
cell.MergeCells = False
joinedCells.Value = cell.Value
End If
Next
' 2. Split original sheet into three based on one col value
' loop through selected column to check if has different values
Const NameCol = "B"
Const HeaderRow = 3
Const FirstRow = 4
Dim SrcSheet As Worksheet
Dim TrgSheet As Worksheet
Dim SrcRow As Long
Dim LastRow As Long
Dim TrgRow As Long
Dim Student As String
Application.ScreenUpdating = False
Set SrcSheet = ActiveSheet
LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
Student = SrcSheet.Cells(SrcRow, NameCol).Value
Set TrgSheet = Nothing
On Error Resume Next
Set TrgSheet = Worksheets(Student)
On Error GoTo 0
If TrgSheet Is Nothing Then
Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
TrgSheet.Name = Student
SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
End If
TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
Next SrcRow
Application.ScreenUpdating = True
' 3. Extract three new worksheets into three workbooks
Dim Pointer As Long
Set MainWorkBook = ActiveWorkbook
Range("E4").Value = MainWorkBook.Sheets.Count
Application.ScreenUpdating = False 'enhance the performance
For Pointer = 2 To MainWorkBook.Sheets.Count
Set NewWorkbook = Workbooks.Add
MainWorkBook.Sheets(Pointer).Copy After:=NewWorkbook.Sheets(1)
Application.DisplayAlerts = False
NewWorkbook.Sheets(1).Delete
Application.DisplayAlerts = True
With NewWorkbook
.SaveAs Filename:="D:\***\Inventory\" & MainWorkBook.Sheets(Pointer).Name & ".xls"
End With
NewWorkbook.Close SaveChanges:=True
Next Pointer
Application.ScreenUpdating = True
End Sub
假设您已经在脚本中的路径中设置了所需的文件名,请更改
Application.DisplayAlerts = True
到
Application.DisplayAlerts = false
以避免收到覆盖警告。
保存后将其改回 true 以防止其他地方出现问题。
希望对您有所帮助