VBA to insert lines and bring in looked up value

[Iron_Man]

Hi folks,

I am hoping for some advice on how to best perform a task in Excel, hopefully via a macro.

I assume two spreadsheets in the same book.

Sheet 1
Column A has a unique identifier, approximately 2,000 lines filled out from column A to T

Sheet 2 has the same identifier in column A with about 10,000 lines (some identifiers in sheet 2 don't exist in sheet1), filled out from column A to K.

I am trying to write a macro to insert a new line under each identifier in Sheet 1, merge all cells from A to T and insert the matching data from column K Sheet 2 (ie identifier 1 in sheet 1 will correlate to identifier 2 in sheet 2 and return the value on the same line in column K).

Ideally, this means by sheet 1 will have 4,000 lines in the end with every second line containing data imported from sheet 2.

As I'm writing this I'm thinking I'm dreaming but maybe some clever cogs will have a good idea

Thanks in advance.
IM

 

[wideboydixon]

Give this a shot:

Public Sub Iron_Man_001()

Dim thisRow As Long
Dim sheetOne As Worksheet
Dim sheetTwo As Worksheet
Dim foundRow As Variant

Set sheetOne = Sheets("Sheet1") ' change the name to match what you have
Set sheetTwo = Sheets("Sheet2") ' change the name to match what you have
thisRow = 1 ' Change to be the first row on sheet 1

Application.ScreenUpdating = False

While sheetOne.Cells(thisRow, "A").Value <> ""
    sheetOne.Rows(thisRow + 1).Insert xlShiftDown
    sheetOne.Range(sheetOne.Cells(thisRow + 1, "A"), sheetOne.Cells(thisRow + 1, "T")).Merge
    foundRow = Application.Match(sheetOne.Cells(thisRow, "A").Value, sheetTwo.Range("A:A"), 0)
    If Not IsError(foundRow) Then sheetOne.Cells(thisRow + 1, "A").Value = sheetTwo.Cells(foundRow, "K").Value
    thisRow = thisRow + 2
Wend

Application.ScreenUpdating = True

End Sub

WBD

 

[Iron_Man]

wideboydixon, this is perfect.

Thank you very much, nothing else to say Out of interest, if I wanted to apply specific formatting (ie the existing line is blue shaded but the new inserted is white with an indent), are they conditions I need to add after the .Merge? And is it possible or would it add too much lag so I should do it manually?

 

[wideboydixon]

You can mess around with the formatting like this:

Public Sub Iron_Man_001()

Dim thisRow As Long
Dim sheetOne As Worksheet
Dim sheetTwo As Worksheet
Dim foundRow As Variant

Set sheetOne = Sheets("Sheet1") ' change the name to match what you have
Set sheetTwo = Sheets("Sheet2") ' change the name to match what you have
thisRow = 1 ' Change to be the first row on sheet 1

Application.ScreenUpdating = False

While sheetOne.Cells(thisRow, "A").Value <> ""
    sheetOne.Rows(thisRow + 1).Insert xlShiftDown
    With sheetOne.Range(sheetOne.Cells(thisRow + 1, "A"), sheetOne.Cells(thisRow + 1, "T"))
        .Merge
        .Interior.Color = RGB(224, 224, 255)
        .HorizontalAlignment = xlCenter
    End With
    foundRow = Application.Match(sheetOne.Cells(thisRow, "A").Value, sheetTwo.Range("A:A"), 0)
    If Not IsError(foundRow) Then sheetOne.Cells(thisRow + 1, "A").Value = sheetTwo.Cells(foundRow, "K").Value
    thisRow = thisRow + 2
Wend

Application.ScreenUpdating = True

End Sub

Just put the necessary colors, alignments etc. there.

WBD

 

[Iron_Man]

Well thank you very very much