Sub 合并文件()
sheetsNum = Sheets.Count
'新建一个对话框对象
Set FolderDialogObject = Application.FileDialog(msoFileDialogFolderPicker)
'配置对话框
With FolderDialogObject
.Title = "请选择要查找的文件夹"
End With
'显示对话框
FolderDialogObject.Show
'获取选择对话框选择的文件夹
Set paths = FolderDialogObject.SelectedItems
If paths.Count = 0 Then
MsgBox "未选中任何文件夹,退出"
Exit Sub
End If
'获取文件夹下面的所有文件
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFiles = fso.GetFolder(paths(1))
If Not objFiles Is Nothing Then
For Each objFile In objFiles.Files
If InStr(objFile.Name, "~$") < 1 And InStr(objFile.Name, ".xls") > 0 Then
'copy选中文件的sheet至主文件中
CopyFileSheets (objFile)
End If
Next
End If
Call 合并工作表(sheetsNum)
End Sub
Sub 合并工作簿()
sheetsNum = Sheets.Count
Dim FileOpen
Dim X As Integer
Application.ScreenUpdating = False
FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Office Excel 文件(*.*),*xls,Microsoft Excel文件(*.xlsx),*.xlsx", MultiSelect:=True, Title:="请选择需要合并的工作簿")
X = 1
If TypeName(FileOpen) = "Boolean" Then
MsgBox "未选择任何文件, 退出."
Exit Sub
End If
While X <= UBound(FileOpen)
CopyFileSheets (FileOpen(X))
X = X + 1
Wend
Call 合并工作表(sheetsNum)
'删除生成的sheets
'Application.DisplayAlerts = False '关闭删除时的弹框提示
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
errhadler:
MsgBox Err.Description
End Sub
Sub 合并工作表(sheetsNum)
ThisWorkbook.Activate
Dim J As Integer
Dim pjMainSheetName As String
For sheetNum = 1 To sheetsNum
If InStr(Sheets(sheetNum).Name, "动态销售定价表") > 0 And InStr(Sheets(sheetNum).Name, "说明") < 1 Then
pjMainSheetName = Sheets(sheetNum).Name
Exit For
End If
Next
On Error Resume Next
Sheets(pjMainSheetName).Activate
Range("A6").EntireRow.Select
'获取合并前所有的项目信息
Dim pjNameDic
Set pjNameDic = CreateObject("Scripting.Dictionary")
mainSheetRow = Sheets(pjMainSheetName).Range("A65536").End(xlUp).Row
ReDim pjNameArray(mainSheetRow)
For itemRow = 7 To mainSheetRow
'将第一列第二列第三列的值作为一个主键值
pjNameDic.Add Cells(itemRow, 2) & Cells(itemRow, 3) & Cells(itemRow, 4) & Cells(itemRow, 5), itemRow
Next
'遍历sheet,将所有sheet的值copy至主excel中
For J = sheetsNum + 1 To Sheets.Count
Sheets(J).Activate
c = Sheets(J).Range("IV7").End(xlToLeft).Column
r = Sheets(J).Range("A65536").End(xlUp).Row
Number = 1
'循环遍历sheet中的行
For Row = 7 To r
'判断是否重复的主键
pjKey = Cells(Row, 2) & Cells(Row, 3) & Cells(Row, 4) & Cells(Row, 5)
If pjNameDic.Item(pjKey) < 1 Then
'主sheet统计栏上面中添加一行空行
Sheets(pjMainSheetName).Rows(Sheets(pjMainSheetName).Range("A65536").End(xlUp).Row + 1).Insert
'如果字典中不存在,则在主sheet中添加一行,并加入到字典中
Range(Row & ":" & Row).Resize(1, c).Select
Application.DisplayAlerts = False '关闭弹框提示
Selection.Copy Destination:=Sheets(pjMainSheetName).Range("A65536").End(xlUp)(2)
pjNameDic.Add pjKey, mainSheetRow + Number
Number = Number + 1
Else
'更新存在的列
For col = 7 To c
cellValue = Cells(Row, col)
Sheets(pjMainSheetName).Activate
Cells(pjNameDic.Item(pjKey), col) = cellValue
Sheets(J).Activate
Next
End If
Next
Next
End Sub
Sub CopyFileSheets(fileNamePath)
Workbooks.Open Filename:=fileNamePath
'获取需要合并的工作簿的序号,放入数组中
Count = 0
For i = 1 To Sheets.Count
If InStr(Sheets(i).Name, "说明") < 1 And InStr(Sheets(i).Name, "动态销售定价表") > 0 Then
Count = Count + 1
End If
Next
If Count > 0 Then
Dim sheetArray
ReDim sheetArray(Count - 1)
num = 0
For i = 1 To Sheets.Count
If InStr(Sheets(i).Name, "说明") < 1 And InStr(Sheets(i).Name, "动态销售定价表") > 0 Then
sheetArray(num) = i
num = num + 1
End If
Next
Application.DisplayAlerts = False
'copy sheet to main excel file
Sheets(sheetArray).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End If
End Sub