VBA help - copy lines n times based on input

stjuch

New Member
Joined
Sep 23, 2020
Messages
8
Office Version
  1. 365
Platform
  1. Windows
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
 

Some videos you may like

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,103
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.
VBA Code:
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

New Member
Joined
Sep 23, 2020
Messages
8
Office Version
  1. 365
Platform
  1. Windows
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.
VBA Code:
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

Well-known Member
Joined
Apr 11, 2012
Messages
10,103
Try:
VBA Code:
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

New Member
Joined
Sep 23, 2020
Messages
8
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Try:
VBA Code:
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

Well-known Member
Joined
Apr 11, 2012
Messages
10,103
Try:
VBA Code:
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

New Member
Joined
Sep 23, 2020
Messages
8
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Try:
VBA Code:
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 :)
 

stjuch

New Member
Joined
Sep 23, 2020
Messages
8
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Apr 11, 2012
Messages
10,103
Try:
VBA Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,122,387
Messages
5,595,879
Members
414,029
Latest member
mrwilker

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
Top