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

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
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

T
  • Question Question
Match specific rows with a column
Replies
1
Views
176
Peter_SSs
Peter_SSs
S
  • Question Question
VBA code to determine InDesign Layout
Replies
6
Views
445
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
116
Hailee994
H
W
  • Question Question
SCHEDULE DASHBOARD VBA CODE (AUTOMATCICALLY TOGGLE TO MATCHING COLUMN)
Replies
0
Views
276
Willkim
W
W
  • Solved
Looking For Tips To Improve My VBA
Replies
8
Views
198
who am i
W

Forum statistics

Threads
1,223,911
Messages
6,175,325
Members
452,635
Latest member
laura12345

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