时间戳

首页 > 解决方案 > 通过所有工作表与索引的VBA EXCEL vlookups

excel - 通过所有工作表与索引的VBA EXCEL vlookups

问题描述

我有一个包含 200 多张表 + 索引表的 excel 文件，我正在尝试浏览所有表以从索引表中复制数据。例如，我有下表：

A   test1
B   test2
C   test3
D   test4

所以我想在索引表中做一个 vlookup，并将列 K 复制到右表中。例如，我希望将“test1”复制到工作表“A”的单元格 A3 中。要查找的表在工作表“INDEX”中，范围 J1:K4。那可能吗？我在这里存储了一个文件！出于保密原因，我编辑了工作表名称和内容，并放置了一个较短的文件。

提前致谢！

标签： excelvba

解决方案

更新工作表

Option Explicit

Sub updateWorksheets()
    
    ' Define constants.
    Const wsName As String = "INDEX"
    Const FirstCellAddress As String = "J1"
    Const dstAddress As String = "A3"
    Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
    
    ' Define Data Range.
    Dim rng As Range
    With wb.Worksheets(wsName).Range(FirstCellAddress).Resize(, 2)
        Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1).Find( _
            What:="*", _
            LookIn:=xlFormulas, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious)
        If rng Is Nothing Then
            Exit Sub
        End If
        Set rng = .Resize(rng.Row - .Row + 1)
    End With
    
    ' Write values from Data Range to Data Array.
    Dim Data As Variant: Data = rng.Value
    
    ' Declare additional variables (to be used in the 'For Next' loop).
    Dim dst As Worksheet ' Current Destination Worksheet
    Dim i As Long ' Data Array Row Counter
    
    ' Loop through rows of Data Array.
    For i = 1 To UBound(Data, 1)
        ' Use the value in the first column to try to create a reference
        ' to the worksheet i.e. check if the worksheet exists.
        Set dst = Nothing
        On Error Resume Next
        Set dst = wb.Worksheets(Data(i, 1))
        On Error GoTo 0
        ' If the worksheet exists,...
        If Not dst Is Nothing Then
            ' ...write value from second column of Data Array
            ' to Destination Cell Range in Current Destination worksheet.
            dst.Range(dstAddress).Value = Data(i, 2)
        End If
    Next i
    
End Sub

推荐阅读