VBA help - copy lines n times based on input

[stjuch]

Hi all,

I'm pretty new to VBA and was wondering if it is possible to create a macro that copies part of a row n times (depending on cell value) to another sheet in the workbook?

Specifically, in attached dummy file I need to copy the data for each row in column A:W in sheet "Model Mapping" n times based number written in sheet "Input" column B and paste it into sheet "Lines" column I:AE

For example, if input in sheet "Input" is 10 in cell B3, I need 10 lines of the corresponding data related to cell A3 inserted in sheet "Lines".

https://easyupload.io/vl1ymr

Is it possible and can something guide me in the right direction?

Thanks a lot.

/stjuch

 

[mumps]

Copy and paste this macro into the worksheet code module. Do the following: right click the tab name for your "Input" sheet and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet. Enter a value in column B and press the RETURN key.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim srcWS As Worksheet, desWS As Worksheet, fnd As Range
    Set srcWS = Sheets("Model Mapping")
    Set desWS = Sheets("Lines")
    Set fnd = srcWS.Range("A:A").Find(Target.Offset(, -1).Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not fnd Is Nothing Then
        fnd.Resize(, 23).Copy desWS.Cells(desWS.Rows.Count, "I").End(xlUp).Offset(1).Resize(Target.Value)
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[stjuch]

Copy and paste this macro into the worksheet code module. Do the following: right click the tab name for your "Input" sheet and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet. Enter a value in column B and press the RETURN key.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim srcWS As Worksheet, desWS As Worksheet, fnd As Range
    Set srcWS = Sheets("Model Mapping")
    Set desWS = Sheets("Lines")
    Set fnd = srcWS.Range("A:A").Find(Target.Offset(, -1).Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not fnd Is Nothing Then
        fnd.Resize(, 23).Copy desWS.Cells(desWS.Rows.Count, "I").End(xlUp).Offset(1).Resize(Target.Value)
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Thanks mumps. This is pretty stop on! Would it be possible to not do it as a worksheet change but as a "normal" macro I can bind to a button in the sheet? Because I suspect users of the sheet maybe will change the values in Input B:B a couple of times which will generate too many lines. I was thinking it just generated all the lines when you hit the button and cleared the content if there is any in sheet "Lines" col I:AE

Thanks a lot again.

 

[mumps]

Try:

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, fnd As Range, model As Range
    Set srcWS = Sheets("Model Mapping")
    Set desWS = Sheets("Lines")
    With desWS
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("I2:AE" & LastRow).ClearContents
    End With
    For Each model In Sheets("Input").Range("A3", Sheets("Input").Range("A" & Rows.Count).End(xlUp))
        Set fnd = srcWS.Range("A:A").Find(model.Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd Is Nothing Then
            fnd.Resize(, 23).Copy desWS.Cells(desWS.Rows.Count, "I").End(xlUp).Offset(1).Resize(model.Offset(, 1).Value)
        End If
    Next model
    Application.ScreenUpdating = True
End Sub

 

[stjuch]

Try:

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, fnd As Range, model As Range
    Set srcWS = Sheets("Model Mapping")
    Set desWS = Sheets("Lines")
    With desWS
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("I2:AE" & LastRow).ClearContents
    End With
    For Each model In Sheets("Input").Range("A3", Sheets("Input").Range("A" & Rows.Count).End(xlUp))
        Set fnd = srcWS.Range("A:A").Find(model.Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd Is Nothing Then
            fnd.Resize(, 23).Copy desWS.Cells(desWS.Rows.Count, "I").End(xlUp).Offset(1).Resize(model.Offset(, 1).Value)
        End If
    Next model
    Application.ScreenUpdating = True
End Sub

Works like a charm! Only thing I need now and can't figure out is how to skip the lines in the Input sheet which are 0 or blank in column B. How can I do that?

Thanks so much again.

 

[mumps]

Try:

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, fnd As Range, model As Range
    Set srcWS = Sheets("Model Mapping")
    Set desWS = Sheets("Lines")
    With desWS
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("I2:AE" & LastRow).ClearContents
    End With
    For Each model In Sheets("Input").Range("A3", Sheets("Input").Range("A" & Rows.Count).End(xlUp))
        If model.Offset(, 1) <> "" And model.Offset(, 1) <> 0 Then
            Set fnd = srcWS.Range("A:A").Find(model.Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd Is Nothing Then
                fnd.Resize(, 23).Copy desWS.Cells(desWS.Rows.Count, "I").End(xlUp).Offset(1).Resize(model.Offset(, 1).Value)
            End If
        End If
    Next model
    Application.ScreenUpdating = True
End Sub

 

[stjuch]

Try:

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, fnd As Range, model As Range
    Set srcWS = Sheets("Model Mapping")
    Set desWS = Sheets("Lines")
    With desWS
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("I2:AE" & LastRow).ClearContents
    End With
    For Each model In Sheets("Input").Range("A3", Sheets("Input").Range("A" & Rows.Count).End(xlUp))
        If model.Offset(, 1) <> "" And model.Offset(, 1) <> 0 Then
            Set fnd = srcWS.Range("A:A").Find(model.Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd Is Nothing Then
                fnd.Resize(, 23).Copy desWS.Cells(desWS.Rows.Count, "I").End(xlUp).Offset(1).Resize(model.Offset(, 1).Value)
            End If
        End If
    Next model
    Application.ScreenUpdating = True
End Sub

Thanks so much. You have saved me a lot of time

 

[mumps]

You are very welcome.

 

[stjuch]

Hi again.

I have a follow up question regarding above code.

Instead of just one column in the input sheet, I need it to be split into 5 different columns, where the user can input a number and then the line will be created n times in "Lines" sheet using the data in model mapping sheet. Also the number in cells B2:F2 in the input sheet should be copied to each line in "Lines" sheet column A.

Right now there's an issue with printing the correct dealer number in column Input sheet column A. Also in order to do this I will have to do 5 for each's, don't know if this is the correct way to go, but it is the only way I see with my knowledge.

Could someone have a look and guide me in the right direction?

Thanks a lot

https://easyupload.io/zfqwq1 - Password: 1234

 

[mumps]

Try:

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long, bottomA As Long, srcWS As Worksheet, desWS As Worksheet, fnd As Range, model As Range, rng As Range
    bottomA = Sheets("Input").Range("A" & Rows.Count).End(xlUp).Row
    Set srcWS = Sheets("Model Mapping")
    Set desWS = Sheets("Lines")
    With desWS
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("A2:X" & LastRow + 1).ClearContents
    End With
    For Each model In Sheets("Input").Range("A3:A" & bottomA)
        If WorksheetFunction.CountA(model.Offset(, 1).Resize(, 5)) > 0 Then
            For Each rng In Range("B" & model.Row).Resize(, 5)
                If rng <> "" Then
                    Set fnd = srcWS.Range("A:A").Find(model.Value, LookIn:=xlValues, lookat:=xlWhole)
                    If Not fnd Is Nothing Then
                        With desWS
                            fnd.Resize(, 23).Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Resize(rng.Value)
                            .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(rng.Value) = Cells(2, rng.Column)
                        End With
                    End If
                End If
            Next rng
        End If
    Next model
    Application.ScreenUpdating = True
End Sub