Question

我有以下代码，虽然不完整，因为我不确定如何填充多个列和行。

代码

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

我的源文件具有以下结构

Name     Value1

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

Name     Value1

问题1

目前，代码只填充单个单元格，我希望它填充允许行。

问题2

我需要能够填充多个列。例如。

Name     Value1     Value2, etc

问题3

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

Answer 1

编辑：您可以修改初始设计以接收两个Range个对象和一个偏移量，然后根据需要进行迭代。您需要打开工作簿并将Range对象分配到其他位置，但这似乎不是现在的挑战。 （以下未经测试）：

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抓住该行。

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

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工作簿合并到单个主列表中

1 个答案: