代码之家 › 专栏 › 技术社区 › Nic

Vlookup Col\u Index\u Number by Header based on Array迭代?

vlookup excel vba arrays

Nic · 技术社区 · 7 年前

我当前的代码遇到问题-我希望有人能提供帮助:

问题: 我正在练习练习册“ABC”中的Vlookup。问题是,我正试图根据工作簿ABC上的标题更改VLOOKUP Col\u Index\u编号。。。

例如:对于MyArray“Food”,我要查找工作簿ABC上“Food Mexican”列的Vlookup Column\U Index\Num,对于MyArray开胃菜,我要查找“Apperizers American”的Vlookup Column\U Index-Num。。。

此外,每个报表的列并不总是位于同一位置,因此必须基于ABC工作簿的第1行标题。

此外,有时可能会跳过数组迭代,例如,如果没有找到“Non-AlcoholicDrinks”。

Sub WIP()
    Dim wb As Workbook
    Dim wsMain As Worksheet
    Dim wsLookup As Worksheet
    Dim rng As Range
    Dim rng2 As Range
    Dim rFind1 As Range
    Dim rFind2 As Range
    Dim rFind3 As Range
    Dim MyArray As Variant
    Dim LookupHeaders As Variant
    Dim LookupHeaders2 As Variant
    Dim LR As Long
    Dim i As Long
    Dim PriceCol As Long
    Dim pricecol2 As Long
    Dim LastColumn As Long
     Dim LastColumn2 As Long
       Dim LastColumn3 As Long
     Dim LastColumn4 As Long
    Dim IndexCol As Long

     'Unformatted Price Row
  Sheets("Consolidate List").Select
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("J:N").Delete
    Columns("J:J").Select
    ActiveWindow.FreezePanes = True
    Range("H2").Select
    ActiveCell.FormulaR1C1 = "New Price"
    ActiveCell.Interior.ColorIndex = 22
         Range("H3:H" & LR).Formula = "=VLOOKUP(RC[-7],'Connect Report'!C[-7]:C[-6],2,FALSE)"
         ActiveCell.EntireColumn.Resize(Rows.Count - 2).Offset(2).Select
 Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Range("I2").Select
    ActiveCell.FormulaR1C1 = "Difference"
    ActiveCell.Interior.ColorIndex = 22
    Range("I3:I" & LR).Formula = "=IF(OR(OR(RC[-2]="""",RC[-1]="""",RC[-1]=""x"",)),"""",RC[-1]-RC[-2])"
         ActiveCell.EntireColumn.Resize(Rows.Count - 2).Offset(2).Select
 Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Set wb = ActiveWorkbook
     Sheets("Consolidate List").Select
    Set wsMain = wb.ActiveSheet
    Set wsLookup = wb.Sheets("Connect Report")     '<-- Change to correct sheet name for the Lookup sheet
    LR = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row
    MyArray = Array("US", "SPAIN", "California")
    LookupHeaders = Array("TTIER", "Time333", "Round6")
  LookupHeaders2 = Array("TELLER5", "Fly7", "Mine4")

    For i = LBound(MyArray) To UBound(MyArray)
        With wsMain.Rows(1)
            Set rFind1 = .Find(What:=MyArray(i), LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
            If Not rFind1 Is Nothing Then
                Set rng = rFind1.Offset(1).Resize(, 8)
                PriceCol = Application.Match("New Opposed Price", rng, 0)
                LastColumn = rFind1.Column + PriceCol
                If wsMain.Cells(rng.Row, LastColumn) <> "New Opposed Price" Then
                    wsMain.Columns(LastColumn).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                    wsMain.Cells(rng.Row, LastColumn).Value = "New Opposed Price"
                    wsMain.Cells(rng.Row, LastColumn).Interior.ColorIndex = 22
                    LastColumn2 = LastColumn + 1
                     wsMain.Columns(LastColumn2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                    wsMain.Cells(rng.Row, LastColumn2).Value = "Difference"
                    wsMain.Cells(rng.Row, LastColumn2).Interior.ColorIndex = 22

                Set rFind2 = wsLookup.Rows(1).Find(LookupHeaders(i), wsLookup.Range("A1"), xlValues, xlWhole)
                If Not rFind2 Is Nothing Then
                    IndexCol = rFind2.Column
                    wsMain.Cells(rng.Row + 1, LastColumn).Resize(LR - 2).Formula = "=VLOOKUP(A" & rng.Row + 1 & ",'Connect Report'!$A:$AL," & IndexCol & ",FALSE)"

                      wsMain.Cells(rng.Row + 1, LastColumn2).Resize(LR - 2).Formula = "=IF(OR(OR(RC[-2]="""",RC[-1]="""",RC[-1]=""x"",)),"""",RC[-1]-RC[-2])"
                              Else
                    MsgBox "Excel could not find " & LookupHeaders(i) & " in the lookup table."
                End If

                Set rng2 = rFind1.Offset(1).Resize(, 8)
                pricecol2 = Application.Match("New Muted Price", rng, 0)
                LastColumn3 = rFind1.Column + pricecol2
                   If wsMain.Cells(rng.Row, LastColumn3) <> "New Muted Price" Then
                    wsMain.Columns(LastColumn3).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                    wsMain.Cells(rng2.Row, LastColumn3).Value = "New Muted Price"
                    wsMain.Cells(rng2.Row, LastColumn3).Interior.ColorIndex = 22
                    LastColumn4 = LastColumn3 + 1
                      wsMain.Columns(LastColumn4).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                    wsMain.Cells(rng2.Row, LastColumn4).Value = "Difference"
                    wsMain.Cells(rng2.Row, LastColumn4).Interior.ColorIndex = 22
                End If

                      Set rFind3 = wsLookup.Rows(1).Find(LookupHeaders2(i), wsLookup.Range("A1"), xlValues, xlWhole)
                If Not rFind3 Is Nothing Then
                    IndexCol = rFind3.Column
                    wsMain.Cells(rng2.Row + 1, LastColumn3).Resize(LR - 2).Formula = "=VLOOKUP(A" & rng2.Row + 1 & ",'Connect Report'!$A:$AL," & IndexCol & ",FALSE)"

                      wsMain.Cells(rng2.Row + 1, LastColumn4).Resize(LR - 2).Formula = "=IF(OR(OR(RC[-2]="""",RC[-1]="""",RC[-1]=""x"",)),"""",RC[-1]-RC[-2])"

                    Else
                    MsgBox "Excel could not find " & LookupHeaders2(i) & " in the lookup table."
                End If
                End If
             End If
        End With
    Next i
End Sub

有人能帮忙吗?我完全不知道如何解决这个问题。此外,我希望我能清楚地描述这个问题。。。这很令人困惑。

2 回复 | 直到 7 年前

tigeravatar 7 年前

我相信这样的事情应该适合你。试试看,让我知道。

Sub tgr()

    Dim wb As Workbook
    Dim wsMain As Worksheet
    Dim wsLookup As Worksheet
    Dim rng As Range
    Dim rFind1 As Range
    Dim rFind2 As Range
    Dim MyArray As Variant
    Dim LookupHeaders As Variant
    Dim LR As Long
    Dim i As Long
    Dim PriceCol As Long
    Dim LastColumn As Long

    Set wb = ActiveWorkbook
    Set wsMain = wb.ActiveSheet
    Set wsLookup = wb.Sheets("ABC")     '<-- Change to correct sheet name for the Lookup sheet
    LR = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row
    MyArray = Array("TEST", "Food", "Non-AlcoholicDrinks", "Appetizers", "Alcoholic Drinks")
    LookupHeaders = Array("TestHeader", "FoodHeader", "Non-AlcoholicDrinksHeader", "AppetizersHeader", "Alcoholic DrinksHeader")

    For i = LBound(MyArray) To UBound(MyArray)
        Set rFind1 = wsMain.Rows(1).Find(What:=MyArray(i), LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
        If Not rFind1 Is Nothing Then
            Set rng = rFind1.Offset(1).Resize(, 8)
            PriceCol = Application.Match("Price", rng, 0)
            LastColumn = rFind1.Column + PriceCol
            If wsMain.Cells(rng.Row, LastColumn) <> "Difference" Then
                wsMain.Columns(LastColumn).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                wsMain.Cells(rng.Row, LastColumn).Value = "Difference"
                wsMain.Cells(rng.Row, LastColumn).Interior.ColorIndex = 22
            End If
            Set rFind2 = wsLookup.Rows(1).Find(LookupHeaders(i), wsLookup.Range("A1"), xlValues, xlPart)
            If Not rFind2 Is Nothing Then
                With wsMain.Cells(rng.Row + 1, LastColumn).Resize(LR - 2)
                    .Formula = "=VLOOKUP(A" & rng.Row + 1 & "," & wsLookup.Range("A:AL").Address(External:=True) & "," & rFind2.Column & ",FALSE)"
                    .Value = .Value 'Convert to values
                End With
            End If
        End If
    Next i

End Sub

Middle 7 年前

这是我编写的一个用户定义函数,用于根据列标题查找的范围,它使用。find方法查找目标单元格。如果列标题位于工作表的顶部,则效果很好。

我希望这能解决您的问题,您可以通过使用 .column 在返回的范围上。

'define a range by looking for a specific text title, and return all the cells to the lastrow of the sheet as a range
Private Function defineColRange(ByVal targetWorkSheet As Worksheet, ByVal targetValue As String, _
                                Optional ByVal visibleOnly As Boolean, Optional ByVal rtnNoTitle As Boolean, _
                                Optional ByVal searchByColumn, Optional ByVal searchBackwards) As Range
    Dim targetlastRow As Long
    Dim targetlastCol As Long
    Dim returnRange As Range
    Dim findTarget As Range

'default visible only mode off

    If IsMissing(visibleOnly) Then
         visibleOnly = False
    End If
    If IsMissing(rtnNoTitle) Then 'Don't return title cell in the range returned
        rtnNoTitle = False
    End If
    If IsMissing(searchByColumn) Then 'Search vertically by column, instead of by rows
        searchByColumn = False
    End If
    If IsMissing(searchBackwards) Then 'Search backwards by rows
        searchBackwards = False
    End If

    'test if targetWorkSheet is not empty
    If targetWorkSheet Is Nothing Then
        MsgBox ("Worksheet pass failed!"), vbExclamation
        Exit Function
    End If

    targetWorkSheet.Activate
    targetlastRow = targetWorkSheet.UsedRange.Find(What:="*", _
                    after:=Range("A1"), _
                    Lookat:=xlPart, _
                    LookIn:=xlFormulas, _
                    Searchorder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row

    targetlastCol = targetWorkSheet.UsedRange.Find(What:="*", _
                    after:=Range("A1"), _
                    Lookat:=xlPart, _
                    LookIn:=xlFormulas, _
                    Searchorder:=xlByColumns, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Column

    'find the range

    If searchByColumn = True Then
        Set findTarget = targetWorkSheet.UsedRange.Find(What:=targetValue, after:=Cells(1, 1), _
                        LookIn:=xlFormulas, Lookat:=xlPart, Searchorder:=xlByColumns, _
                        SearchDirection:=xlNext, MatchCase:=False)
    ElseIf searchBackwards = True Then
        Set findTarget = targetWorkSheet.UsedRange.Find(What:=targetValue, after:=Cells(1, targetlastCol), _
                        LookIn:=xlFormulas, Lookat:=xlPart, Searchorder:=xlByRows, _
                        SearchDirection:=xlPrevious, MatchCase:=False)
    Else
        Set findTarget = targetWorkSheet.UsedRange.Find(What:=targetValue, after:=Cells(1, 1), _
                        LookIn:=xlFormulas, Lookat:=xlPart, Searchorder:=xlByRows, _
                        SearchDirection:=xlNext, MatchCase:=False)
    End If

    If findTarget Is Nothing Then
        Debug.Print ("Did not find columne title """ & targetValue & ""), vbExclamation
        Exit Function
    Else
        Dim tRow, tCol As Long
        tRow = findTarget.Row
        tCol = findTarget.Column

        On Error Resume Next
        If visibleOnly = False Then
            If rtnNoTitle = False Then
                Set returnRange = targetWorkSheet.Range(Cells(tRow, tCol), Cells(targetlastRow, tCol))
                Set defineColRange = returnRange
            Else
                Set returnRange = targetWorkSheet.Range(Cells(tRow + 1, tCol), Cells(targetlastRow, tCol))
                Set defineColRange = returnRange
            End If
        Else
            If rtnNoTitle = False Then
                Set returnRange = targetWorkSheet.Range(Cells(tRow, tCol), Cells(targetlastRow, tCol)).SpecialCells(xlCellTypeVisible)
                Set defineColRange = returnRange
            Else
                Set returnRange = targetWorkSheet.Range(Cells(tRow + 1, tCol), Cells(targetlastRow, tCol)).SpecialCells(xlCellTypeVisible)
                Set defineColRange = returnRange
            End If
        End If

        If Err <> 0 Then
            Debug.Print "Worksheet: " & targetWorkSheet.Name & " Column Name: " & targetValue
        End If
        On Error GoTo 0
        Err.Clear
    End If

End Function