我需要合并两个Excel文件，但每个文件只需要某些列。我需要使用userform选择要合并的两个文件，然后使用列映射来选择每个工作表中哪些列需要出现在新输出表中的哪个位置。
到目前为止，我有这个。
Private Sub AddFilesButton_Click()
Dim arrFiles As Variant
On Error GoTo ErrMsg
'Let the user choose the files they want to merge
#If Mac Then
arrFiles = Select_File_Or_Files_Mac()
#Else
arrFiles = Application.GetOpenFilename("Excel Files (*.xls; *.xlsx), *.xls;*.xlsx", 1, "Choose Excel Files", "Select", True)
#End If
If IsNull(arrFiles) Or UBound(arrFiles) = -1 Then
MsgBox "Please choose at least one Excel file"
Else
For Each file In arrFiles
FilesListBox.AddItem file
Next file
MergeButton.Enabled = True
End If
ErrMsg:
If Err.Number <> 0 Then
MsgBox "There was an error. Please try again. [" & Err.Description & "]"
End If
End Sub
Private Sub CancelButton_Click()
Unload Me
End Sub
Private Sub MergeButton_Click()
Dim fileName As Variant
Dim wb As Workbook
Dim s As Sheet1
Dim thisSheet As Sheet1
Dim lastUsedRow As Range
Dim columnMap As Collection
Dim filePath As Variant
Dim dataRange As Range
Dim insertAtRowNum As Integer
Dim outColName As String
Dim colName As String
Dim fromRange As String
Dim fromRangeToCopy As Range
Dim toRange As String
On Error GoTo ErrMsg
Application.ScreenUpdating = False
Set thisSheet = ThisWorkbook.ActiveSheet
For i = 0 To FilesListBox.ListCount - 1
fileName = FilesListBox.List(i, 0)
'Get the map of columns for this file
Set columnMap = MapColumns(fileName)
'Open the spreadsheet in ReadOnly mode
Set wb = Application.Workbooks.Open(fileName, ReadOnly:=True)
For Each sourceSheet In wb.Sheets
'Get the used range (i.e. cells with data) from the opened spreadsheet
If firstRowHeaders And i > 0 Then 'Only include headers from the first spreadsheet
Dim mr As Integer
mr = wb.ActiveSheet.UsedRange.Rows.Count
Set dataRange = wb.ActiveSheet.UsedRange.Offset(1, 0).Resize(mr - 1)
Else
Set dataRange = wb.ActiveSheet.UsedRange
End If
For Each col In dataRange.Columns
'Get corresponding output column. Empty string means no mapping
colName = GetColName(col.Column)
outColName = GetOutputColumn(columnMap, colName)
If outColName <> "" Then
fromRange = colName & 1 & ":" & colName & dataRange.Rows.Count
Set fromRangeToCopy = dataRange.Range(fromRange)
fromRangeToCopy.Copy
toRange = outColName & insertAtRowNum & ":" & outColName & (insertAtRowNum + fromRangeToCopy.Rows.Count - 1)
thisSheet.Range(toRange).PasteSpecial
End If
Next col
insertAtRowNum = insertAtRowNum + dataRange.Rows.Count
Next sourceSheet
Application.CutCopyMode = False
Next i
ThisWorkbook.Save
Set wb = Nothing
#If Mac Then
'Do nothing. Closing workbooks fails on Mac for some reason
#Else
'Close the workbooks except this one
Dim file As String
For i = 0 To FilesListBox.ListCount - 1
file = FilesListBox.List(i, 0)
file = Right(file, Len(file) - InStrRev(file, Application.PathSeparator, , 1))
Workbooks(file).Close SaveChanges:=False
Next i
#End If
Application.ScreenUpdating = True
Unload Me
ErrMsg:
If Err.Number <> 0 Then
MsgBox "There was an error. Please try again. [" & Err.Description & "]"
End If
End Sub
Function MapColumns(fileName As Variant) As Object
Dim colMap As New Collection
Select Case fileName
Case "ExcelFile1.xlsx"
colMap.Add Key:="C", Item:="A"
colMap.Add Key:="D", Item:="B"
colMap.Add Key:="E", Item:="C"
colMap.Add Key:="I", Item:="D"
Case "ExcelFile2.xlsx"
colMap.Add Key:="B", Item:="F"
colMap.Add Key:="J", Item:="G"
colMap.Add Key:="H", Item:="H"
colMap.Add Key:="C", Item:="I"
End Select
Set MapColumns = colMap
End Function
Function GetOutputColumn(columnMap As Collection, col As String) As String
Dim outCol As String
outCol = ""
If columnMap.Count > 0 Then
outCol = columnMap.Item(col)
End If
GetOutputColumn = outCol
End Function
'From: http://www.mrexcel.com/forum/excel-questions/16444-getting-column-name-given-column-number.html
Function GetColName(ColumnNumber)
FuncRange = Cells(1, ColumnNumber).AddressLocal(False, False) 'Creates Range (defaults Row to 1) and retuns Range in xlA1 format
FuncColLength = Len(FuncRange) 'finds length of range reference
GetColName = Left(FuncRange, FuncColLength - 1) 'row always "1" therefore take 1 away from string length and you are left with column ref
End Function
'From: http://msdn.microsoft.com/en-us/library/office/hh710200%28v=office.14%29.aspx#odc_xl4_ta_ProgrammaticallySelectFileforMac_DifferencesWindowsandMac
Function Select_File_Or_Files_Mac() As Variant
Dim MyPath As String
Dim MyScript As String
Dim MyFiles As String
Dim MySplit As Variant
Dim N As Long
Dim Fname As String
Dim mybook As Workbook
On Error Resume Next
MyPath = MacScript("return (path to documents folder) as String")
'Or use MyPath = "Macintosh HD:Users:Ron:Desktop:TestFolder:"
' In the following statement, change true to false in the line "multiple
' selections allowed true" if you do not want to be able to select more
' than one file. Additionally, if you want to filter for multiple files, change
' {""com.microsoft.Excel.xls""} to
' {""com.microsoft.excel.xls"",""public.comma-separated-values-text""}
' if you want to filter on xls and csv files, for example.
MyScript = _
"set applescript's text item delimiters to "","" " & vbNewLine & _
"set theFiles to (choose file of type " & _
" {""com.microsoft.Excel.xls"",""org.openxmlformats.spreadsheetml.sheet""} " & _
"with prompt ""Please select a file or files"" default location alias """ & _
MyPath & """ multiple selections allowed true) as string" & vbNewLine & _
"set applescript's text item delimiters to """" " & vbNewLine & _
"return theFiles"
MyFiles = MacScript(MyScript)
On Error GoTo 0
MySplit = False 'Assume no files = cancel
If MyFiles <> "" Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
MySplit = Split(MyFiles, ",")
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
Select_File_Or_Files_Mac = MySplit
End Function
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Contributed by Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function