用不同的列合并2个Excel文件，使用用户表单select文件，然后使用列映射

我需要合并两个Excel文件，但只有来自每个特定的列。 我需要使用一个用户窗体来select要合并的两个文件，然后还可以使用列映射来select每个工作表中哪些列需要出现在新输出工作表中的哪个位置。

到目前为止，我有这个。

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 (ie 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