将多个Excel工作簿合并到一个主列表中 [英] Merge multiple Excel workbooks into single masterlist

问题描述

我不确定以下代码，因为我不确定如何填充多个列和行.

I have the following code albeit incomplete as i am unsure how i can populate multiple columns and rows.

代码

Sub VlookMultipleWorkbooks()

    Dim lookFor As Range
    Dim srchRange As Range

    Dim book1 As Workbook
    Dim book2 As Workbook

    Dim book1Name As String
    book1Name = "destination.xls"    'modify it as per your requirement

    Dim book1NamePath As String
    book1NamePath = ThisWorkbook.Path & "\" & book1Name

    Dim book2Name As String
    book2Name = "source.xls"    'modify it as per your requirement

    Dim book2NamePath As String
    book2NamePath = ThisWorkbook.Path & "\" & book2Name

'    Set book1 = ThisWorkbook
    Set book1 = Workbooks(book1Name)

    If IsOpen(book2Name) = False Then Workbooks.Open (book2NamePath)
    Set book2 = Workbooks(book2Name)

    Set lookFor = book1.Sheets(1).Cells(2, 1)   ' value to find
    Set srchRange = book2.Sheets(1).Range("A:B")    'source

    lookFor.Offset(0, 1).Value = Application.VLookup(lookFor, srchRange, 2, False)

End Sub

我的源文件具有以下结构

My source file has the following structure

Name     Value1

我的目标文件具有以下结构

My destination file has the following structure

Name     Value1

问题1

当前代码仅填充单个单元格，我希望它填充允许行.

Currently the code only populates a single cell where i would like it to populate allow rows.

问题2

我需要能够填充多列.例如.

I need to be able to populate multiple columns. For example.

Name     Value1     Value2, etc

问题3

有多个源文件需要合并到一个主列表中.

There are multiple source files that need to merge into a single master list.

推荐答案

编辑:您可以修改初始设计，以使用两个 Range 对象和一个偏移量，然后根据需要进行迭代.您需要打开工作簿并在其他地方分配 Range 对象，但这似乎并不是当前的挑战.(以下内容未经测试):

You could modify your initial design to take in two Range objects and an offset, then iterate as necessary. You'll need to open your workbooks and assign the Range objects elsewhere, but that doesn't seem to be the challenge right now. (Below is untested):

Sub EvenCoolerVLookup(SourceRange As Range, OffsetColumns As Long, LookupRange As Range)

Dim Cell As Range

'vet range objects and make sure they fail an Is Nothing test
'....

For Each Cell In SourceRange
    'do any special prep here
    '...
    Cell.Offset(0, OffsetColumns).Value = Application.VLookup(Cell, LookupRange, 2, False)
    'do any special cleanup here
    '...
Next Cell

'do anything else here
'....

End Sub

这应该可以帮助您解决问题1 .要解决问题2 ，您将无法使用 Application.Vlookup ，但可以使用 Range.Find 返回 Range 对象，您可以通过 Range.Row 从中获取行.

That should help you solve Problem 1. To solve Problem 2, you won't be able to use Application.Vlookup, but you can instead use Range.Find to return a Range object, from which you can grab the row via Range.Row.

原始响应:这应该可以为问题3 合并源文件.结果将作为 xlsx 文件保存到与运行代码的文件相同的目录中:

Original Response: This should work to combine source files for Problem 3. The results will be saved as an xlsx file to the same directory as the file from which the code is run:

Option Explicit

'let's do some combining y'all!
Sub CombineSelectedFiles()

Dim TargetFiles As FileDialog
Dim TargetBook As Workbook, CombinedBook As Workbook
Dim TargetSheet As Worksheet, CombinedSheet As Worksheet
Dim TargetRange As Range, AddNewRange As Range, _
    FinalRange As Range
Dim LastRow As Long, LastCol As Long, Idx As Long, _
    LastCombinedRow As Long
Dim CombinedFileName As String
Dim RemoveDupesArray() As Variant

'prompt user to pick files he or she would like to combine
Set TargetFiles = UserSelectMultipleFiles("Pick the files you'd like to combine:")
If TargetFiles.SelectedItems.Count = 0 Then Exit Sub '<~ user clicked cancel

'create a destination book for all the merged data
Set CombinedBook = Workbooks.Add
Set CombinedSheet = CombinedBook.ActiveSheet

'loop through the selected workbooks and combine data
For Idx = 1 To TargetFiles.SelectedItems.Count

    Set TargetBook = Workbooks.Open(TargetFiles.SelectedItems(Idx))
    Set TargetSheet = TargetBook.ActiveSheet

    If Idx = 1 Then
        TargetSheet.Cells.Copy Destination:=CombinedSheet.Cells(1, 1)
    Else
        LastRow = FindLastRow(TargetSheet)
        LastCol = FindLastCol(TargetSheet)
        With TargetSheet
            Set TargetRange = .Range(.Cells(2, 1), .Cells(LastRow, LastCol))
        End With
        LastCombinedRow = FindLastRow(CombinedSheet)
        With CombinedSheet
            Set AddNewRange = .Range(.Cells(LastCombinedRow + 1, 1), _
                .Cells(LastCombinedRow + 1 + LastRow, LastCol))
        End With
        TargetRange.Copy Destination:=AddNewRange
    End If

    TargetBook.Close SaveChanges:=False

Next Idx

'set up a final range for duplicate removal
LastCombinedRow = FindLastRow(CombinedSheet)
With CombinedSheet
    Set FinalRange = .Range(.Cells(1, 1), .Cells(LastCombinedRow, LastCol))
End With

'populate the array for use in the duplicate removal
ReDim RemoveDupesArray(LastCol)
For Idx = 0 To (LastCol - 1)
    RemoveDupesArray(Idx) = Idx + 1
Next Idx
FinalRange.RemoveDuplicates Columns:=Evaluate(RemoveDupesArray), Header:=xlYes

'save the results
CombinedFileName = ThisWorkbook.Path & "\Combined_Data"
Application.DisplayAlerts = False
CombinedBook.SaveAs FileName:=CombinedFileName, FileFormat:=51
CombinedBook.Close SaveChanges:=False
Application.DisplayAlerts = True

End Sub

'prompt user to select files then return the selected fd object
Public Function UserSelectMultipleFiles(DisplayText As String) As FileDialog

Dim usmfDialog As FileDialog

Set usmfDialog = Application.FileDialog(msoFileDialogOpen)
With usmfDialog
    .AllowMultiSelect = True
    .Title = DisplayText
    .ButtonName = ""
    .Filters.Clear
    .Filters.Add ".xlsx files", "*.xlsx"
    .Filters.Add ".xlsb files", "*.xlsb"
    .Filters.Add ".xlsm files", "*.xlsm"
    .Filters.Add ".xls files", "*.xls"
    .Filters.Add ".csv files", "*.csv"
    .Filters.Add ".txt files", "*.txt"
    .Show
End With
Set UserSelectMultipleFiles = usmfDialog
End Function

'identify last row in a worksheet
Public Function FindLastRow(Sheet As Worksheet) As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        FindLastRow = Sheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Else
        FindLastRow = 1
    End If
End Function

'identify last col in a worksheet
Public Function FindLastCol(Sheet As Worksheet) As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        FindLastCol = Sheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    Else
        FindLastCol = 1
    End If
End Function

这篇关于将多个Excel工作簿合并到一个主列表中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！