VBA to Auto-insert column given a match

[dmr3796]

Hi All,I'm searching for a VBA approach to do a lookup.I want to search for a cell value in a column, and return the next 2 adjacent values (columns B&C) to the right of the search. Some cell values have MULTIPLE matches, and I'm looking to see how I can auto add rows underneath and return all sets of adjacent values (2 rows added underneath for 3 matches, 1 underneath for 2 matches, etc....)

Specific Example:

I want to search for the value in "Sheet1", cell A2 in "Sheet2", column A.

Hypothetically, lets say the matches in "Sheet2" lay in cell A7, A8, A9.

In "Sheet1" I want cell B2 and C2 to contain the adjacent values, and 2 rows added underneath so cells B3:C3, and B4:C4 can contain the other 2 matches' adjacent values.

Please let me know if I can clarify further. Thanks!!!

 

[JackDanIce]

Try:

Sub MatchReturnValues()
    
    Dim arr()   As Variant
    Dim x       As Long
    Dim LR      As Long
    
    Application.ScreenUpdating = False
    
    With Sheets("Sheet1")
        LR = .Cells(.Rows.count, 1).End(xlUp).row
        .Cells(1, 1).Resize(LR).RemoveDuplicates Columns:=Array(1), header:=xlYes
        LR = Application.Max(2, .Cells(.Rows.count, 1).End(xlUp).row)
        With .Cells(1, 1).Resize(LR)
            arr = .Value
            .Resize(, 3).ClearContents
        End With
    End With
    
    With Sheets("Sheet2")
        If .AutoFilterMode Then .AutoFilterMode = False
        LR = .Cells(.Rows.count, 1).End(xlUp).row
        With .Cells(1, 1).Resize(LR, 3)
            .AutoFilter
            For x = LBound(arr, 1) + 1 To UBound(arr, 1)
                On Error Resume Next
                .AutoFilter Field:=1, Criteria1:=arr(x, 1)
                .Offset(1).Resize(LR - 1).SpecialCells(xlCellTypeVisible).Copy
                Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                On Error GoTo 0
            Next x
        End With
    End With
    
    Application.ScreenUpdating = True
    
    Erase arr
    
End Sub

 

[dmr3796]

Worked very Well!

I was wondering however if there's an edit/addition to the code that can be made so it creates a whole new row throughout the sheet rather than just in columns A & B?

Thanks for all your help Jack!

 

[JackDanIce]

You're welcome, though I do not understand what you mean by your edit request, on what sheet? I'm guessing at what you want based on our code, I do not have your sheet in front of me, you need to be more precise please.

 

[dmr3796]

Sorry about that.

So at the moment, when a single value has multiple matches, a line is created beneath the value to accommodate the second match. However, that line is only added to columns A,B, and C. There is data in further columns and when the line is currently added, it mismatches the information. Can you make the additional line extend out to column Z or further? Thanks!

 

[JackDanIce]

Do you mean Sheet1 or Sheet2? Why didn't you mention extending to column Z or further initially?

Try:

Sub MatchReturnValues()
    
    Dim arr()   As Variant
    Dim x       As Long
    Dim LR      As Long
    Dim LC      As Long
    
    Application.ScreenUpdating = False
    
    With Sheets("Sheet1")
        LR = .Cells(.Rows.count, 1).End(xlUp).row
        LC = .Cells(1, .Columns.count).End(xlToLeft).column
        .Cells(1, 1).Resize(LR, LC).RemoveDuplicates Columns:=Array(1), header:=xlYes
        'LR = Application.Max(2, .Cells(.Rows.count, 1).End(xlUp).row)
        With .Cells(1, 1).Resize(LR, LC)
            arr = .Value
            .ClearContents
        End With
    End With
    
    With Sheets("Sheet2")
        If .AutoFilterMode Then .AutoFilterMode = False
        LR = .Cells(.Rows.count, 1).End(xlUp).row
        With .Cells(1, 1).Resize(LR, 3)
            .AutoFilter
            For x = LBound(arr, 1) + 1 To UBound(arr, 1)
                If LenB(arr(x, 1)) = 0 Then Exit For
                On Error Resume Next
                .AutoFilter Field:=1, Criteria1:=arr(x, 1)
                .Offset(1).Resize(LR - 1).SpecialCells(xlCellTypeVisible).Copy
                Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                On Error GoTo 0
            Next x
        End With
        .AutoFilterMode = False
    End With
    
    Application.ScreenUpdating = True
    
    Erase arr
    
End Sub

 

[dmr3796]

Hey Jack,

All the auto inserting of rows and pulling of data will happen in sheet1. This is how the exact formatting of sheet 1 is

Lookup Values

x

x

x

x

x

x

x

Return 1

Return 2

x

x

x

x

<tbody>
</tbody>

columns, I, J for the return values (adjacent cells from sheet2). The data runs all the way to column N in excel so the row has to extend beyond that. Sorry for the vagueness initially. Sheet 2 seems to be fine when i run the code, but sheet 1 still doesn't have the new row extending all the way through. Also, can you have the return pop up in columns I & J instead? Thanks!!

 

[JackDanIce]

Try:

[/COLOR]Sub MatchReturnValues()
    
    Dim arr()   As Variant
    Dim x       As Long
    Dim LR      As Long
    Dim LC      As Long
    
    Application.ScreenUpdating = False
    
    With Sheets("Sheet1")
        LR = .Cells(.Rows.count, 1).End(xlUp).row
        LC = .Cells(1, .Columns.count).End(xlToLeft).column
        .Cells(1, 1).Resize(LR, LC).RemoveDuplicates Columns:=Array(1), header:=xlYes
        'LR = Application.Max(2, .Cells(.Rows.count, 1).End(xlUp).row)
        With .Cells(1, 1).Resize(LR, LC)
            arr = .Value
            .ClearContents
        End With
    End With
    
    With Sheets("Sheet2")
        If .AutoFilterMode Then .AutoFilterMode = False
        LR = .Cells(.Rows.count, 1).End(xlUp).row
        LC = .Cells(1, .Columns.count).End(xlToLeft).column
        With .Cells(1, 1).Resize(LR, LC)
            .AutoFilter
            For x = LBound(arr, 1) + 1 To UBound(arr, 1)
                If LenB(arr(x, 1)) = 0 Then Exit For
                On Error Resume Next
                .AutoFilter Field:=1, Criteria1:=arr(x, 1)
                .Offset(1).Resize(LR - 1).SpecialCells(xlCellTypeVisible).Copy
                Sheets("Sheet1").Cells(Rows.count, 9).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                On Error GoTo 0
            Next x
        End With
        .AutoFilterMode = False
    End With
    
    Application.ScreenUpdating = True
    
    Erase arr
    
End Sub

 

[dmr3796]

Maybe further clarification can help

Hey All,

Im searching for a macro that will find matches based off a certain lookup value, and auto insert a row underneath for multiple matches.

The sheet where the macro will take place will look as such starting with column A: "Sheet1"

Lookup Values

x

x

x

x

x

x

x

Return 1

Return 2

x

x

x

x

<tbody>
</tbody>

This is the sheet that's going to be searched: "Sheet2"

Lookup Values

x

I want this

I want this

x

x

x

x

x

x

x

x

x

x

<tbody>
</tbody>

I want the macro to search sheet2 for "Lookup values" and return the values in the "I want this" columns inside of the "return 1 & 2" columns

Additionally, where this gets tricky is that some lookup values have MULTIPLE matches. If there is 2 matches I want a row inserted under to accomodate the second match, placing all the return values in the same columns as specified above.

***Columns labeled as "x" IN 'SHEET1' contain data that MUST align to the respective lookup value, so it's important that if a new row is inserted due to multiple matches, that the row extends PAST those "x" columns to keep the data aligned**

Please let me know if I can clarify further!