VBA中的3个vlookup

时间:2017-03-16 16:26:38

标签: excel vba excel-vba vlookup

我最近加入,期待与社区合作!

这是我有史以来的第一个VBA项目。我有一个构建宏的项目,它需要使用几个vlookup公式。该公式在后续选项卡上查找转换。因此,对于选项卡1列1上的值,它在选项卡2上查找;对于选项卡1列2,它在选项卡3上查找,依此类推。

问题在于查找似乎更像是“查找/替换”,而不仅仅是完全匹配的真实查找。下面,到目前为止,我的研究得到了什么。我知道还有很多东西需要学习 - 请帮忙!

谢谢!

'Insert Crosswalk columns
    Columns("H:H").Insert
    Set Rng = Range("H2:H" & Range("A:A").End(xlDown).Row)
    Rng.FormulaR1C1 = "=VLOOKUP(RC[-1],Crosswalk_1!C[-7]:C[-6],2,0)"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "Crosswalk_1"

    Columns("J:J").Insert
    Set Rng = Range("J2:J" & Range("A:A").End(xlDown).Row)
    Rng.FormulaR1C1 = "=VLOOKUP(RC[-1],Crosswalk_2!C[-9]:C[-8],2,0)"
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "Crosswalk_2"

    Columns("K:K").Insert
    Set Rng = Range("K2:K" & Range("A:A").End(xlDown).Row)
    'Rng.FormulaR1C1 = "=VLOOKUP(RC[1],Crosswalk_3!C[-10]:C[-9],2,0)"
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "Crosswalk_3"

这是FULL宏 - 我认为问题在于查找,但我可能错了!

Sub MainMacro()

If MsgBox("Before starting, ensure Entity ID is ascending", vbYesNo, "Input Required") = vbYes Then
   MsgBox "Please do not use Excel while this macro is running."
Dim Rng As Range

'Insert "Formula" columns
    Columns("C:C").Insert
    Set Rng = Range("C2:C" & Range("A:A").End(xlDown).Row)
    Rng.FormulaR1C1 = "=IF(RC[-1]=R[1]C[-1],1,0)"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Formula1"
    Columns("D:D").Insert
    Set Rng = Range("D2:D" & Range("A:A").End(xlDown).Row)
    Rng.FormulaR1C1 = "=IF(RC[-2]=R[-1]C[-2],1,0)"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Formula2"

    Columns("E:E").Insert
    Set Rng = Range("E2:E" & Range("A:A").End(xlDown).Row)
    Rng.FormulaR1C1 = "=CONCATENATE(RC[-2],RC[-1])"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "Concatenate1"

'Insert Crosswalk columns
    Columns("H:H").Insert
    Set Rng = Range("H2:H" & Range("A:A").End(xlDown).Row)
    Rng.FormulaR1C1 = "=VLOOKUP(RC[-1],Crosswalk_1!C[-7]:C[-6],2,0)"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "Crosswalk_1"

    Columns("J:J").Insert
    Set Rng = Range("J2:J" & Range("A:A").End(xlDown).Row)
    Rng.FormulaR1C1 = "=VLOOKUP(RC[-1],Crosswalk_2!C[-9]:C[-8],2,0)"
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "Crosswalk_2"

    Columns("K:K").Insert
    Set Rng = Range("K2:K" & Range("A:A").End(xlDown).Row)
    Rng.FormulaR1C1 = "=VLOOKUP(RC[1],Crosswalk_3!C[-10]:C[-9],2,0)"
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "Crosswalk_3"

'Copy&Paste Values

    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select

'Clean-up & Final Formatting
    Range("G1").Select
    Range("G1").Cut Destination:=Range("H1")
    Range("I1").Select
    Range("I1").Cut Destination:=Range("J1")
    Range("L1").Select
    Range("L1").Cut Destination:=Range("K1")
    Columns("G:G").Select
    Selection.Delete Shift:=xlToLeft
    Columns("H:H").Select
    Selection.Delete Shift:=xlToLeft
    Columns("J:J").Select
    Selection.Delete Shift:=xlToLeft
    Columns("G:I").Select
    Selection.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Application.CutCopyMode = False

'Apply Filter to isolate duplicates

    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
    Application.CutCopyMode = False
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.AutoFilter
    ActiveSheet.Range("$A:$I").AutoFilter Field:=5, Criteria1:=Array( _
    "01", "10", "11"), Operator:=xlFilterValues

'Delete dupes
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    ActiveSheet.Range("$A:$L").RemoveDuplicates Columns:=Array(1, 2, 6, 7, 8, 9), Header:=xlYes

'Final De-Dupe Process
    Columns("C:E").Select
    Selection.Delete Shift:=xlToLeft
    Range("A1").Select

    Columns("C:C").Insert
    Set Rng = Range("C2:C" & Range("A:A").End(xlDown).Row)
    Rng.FormulaR1C1 = "=IF(RC[-1]=R[1]C[-1],1,0)"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Formula1"

    Columns("D:D").Insert
    Set Rng = Range("D2:D" & Range("A:A").End(xlDown).Row)
    Rng.FormulaR1C1 = "=IF(RC[-2]=R[-1]C[-2],1,0)"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Formula2"

    Columns("E:E").Insert
    Set Rng = Range("E2:E" & Range("A:A").End(xlDown).Row)
    Rng.FormulaR1C1 = "=CONCATENATE(RC[-2],RC[-1])"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "Duplicate Status"

    'Copy&Paste Values
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Columns("C:D").Select
    Selection.Delete Shift:=xlToLeft
        Range("C1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColor = 12632256
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

'Replace "01", "10", "11" with "Duplicate"
    Columns("C:C").Select
    Selection.Replace What:="10", Replacement:="Duplicate", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="01", Replacement:="Duplicate", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="11", Replacement:="Duplicate", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

'Clear filter
    Range("C1").Select
    ActiveWorkbook.Worksheets("Inputdata (3)").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Inputdata (3)").AutoFilter.Sort.SortFields.Add Key _
        :=Range("C1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Inputdata (3)").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'Final message for user (manually check for remaining duplicates)
    Range("A1").Select
   MsgBox "Macro Complete! Remaining duplicates require manual editing."

 End If
 End Sub

0 个答案:

没有答案