VBA to Auto-insert column given a match

D

dmr3796

New Member
Joined
Jul 5, 2017
Messages
11
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!!!
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
Sort by date Sort by votes
Try:
Code: 
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
 
Upvote 0
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!
 
Upvote 0
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.
 
Upvote 0
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!
 
Upvote 0
Do you mean Sheet1 or Sheet2? Why didn't you mention extending to column Z or further initially?

Try:
Code: 
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
 
Upvote 0
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

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Lookup Values[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]Return 1[/TD]
[TD]Return 2[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


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!!
 
Last edited:
Upvote 0
Try:
Code: 
[/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
 
Upvote 0
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"

[TABLE="class: cms_table_cms_table_grid, width: 500"]
<tbody>[TR]
[TD]Lookup Values[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]Return 1[/TD]
[TD]Return 2[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]




This is the sheet that's going to be searched: "Sheet2"
[TABLE="class: cms_table_cms_table_grid, width: 500"]
<tbody>[TR]
[TD]Lookup Values[/TD]
[TD]x[/TD]
[TD]I want this[/TD]
[TD]I want this[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


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!
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
Vlookup/Match for multiple criteria across worksheets
Replies
8
Views
165
Fluff
Fluff
L
  • Solved
VBA to match cell contents across multiple sheets and copy data from a corresponding cell
Replies
7
Views
225
lyntanos
L
T
  • Question Question
Match specific rows with a column
Replies
1
Views
201
Peter_SSs
Peter_SSs
S
  • Question Question
VBA code to determine InDesign Layout
Replies
6
Views
525
Akuini
Akuini
H
  • Question Question
Using XLOOKUP in VBA to lookup value underneath specific header name (columns can change depending on worksheet)
Replies
0
Views
166
Hailee994
H

Forum statistics

Threads
1,224,828
Messages
6,181,201
Members
453,022
Latest member
RobertV1609

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top