Copying a row based on a integer in a cell

Solved
Sheepy_777
Posts
3
Registration date
Wednesday February 16, 2022
Status
Member
Last seen
February 23, 2022
- Feb 16, 2022 at 11:48 AM
TrowaD
Posts
2880
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
May 2, 2022
- Feb 24, 2022 at 11:43 AM
Hello,
I am needing help making a macro that will allow me to do a number of things, that may or may not be able to be done with one single macro. ( hopefully 1 macro) if not possible thats okay.
1: I need to be able to copy a row X amount of times based on a number in a cell. ( Column 7), But when it copies based on that value i need column 4 to say Pieces. When i copy the row based on the cell value in column 10, i need column 4 to say Skids for each copied row.
2: When copying the row i need the copied rows to ignore column 8 entirely or when the column is copied with the row it has a value of 0.
I will be needing to do this action for various amounts of rows depending on the day, it wont be the same every time.

I had found this VBA code, it is what i'm looking for when needing a row copied but I need to to be more specific with the above alterations. I need the macro to kind of work like this.

Dim xRg As Range

Dim xCRg As Range

Dim xFNum As Integer

Dim xRN As Integer

On Error Resume Next

SelectRange:

xTxt = ActiveWindow.RangeSelection.Address

Set xRg = Application.InputBox("Select the number value", "Text box", xTxt, , , , , 8)

If xRg Is Nothing Then Exit Sub

If xRg.Columns.Count > 1 Then

MsgBox "Please select single column!"

GoTo SelectRange

End If

Application.ScreenUpdating = False

For xFNum = xRg.Count To 1 Step -1

Set xCRg = xRg.Item(xFNum)

xRN = CInt(xCRg.Value) With Rows(xCRg.Row)

.Copy

.Resize(xRN).Insert

End With

Next Application.ScreenUpdating = True

End Sub


System Configuration: Windows / Chrome 98.0.4758.102

2 replies

TrowaD
Posts
2880
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
May 2, 2022
509
Feb 17, 2022 at 12:10 PM
Hi Sheepy,

Could you show some sample data of how your data looks now and how you want it to look after runnning the code?

Best regards,
Trowa
1
Sheepy_777
Posts
3
Registration date
Wednesday February 16, 2022
Status
Member
Last seen
February 23, 2022

Feb 21, 2022 at 10:12 AM



The First image is the beginning of the whole process. I am needing each row to be copied X amount of times based on the integer in column 7 and column 10. But when it copies each line i need it to ignore column 8. And when we copy based on column 10 i need column 4 to say Pallets not Pieces. Second image shows what the finish product should Look like.
0
TrowaD
Posts
2880
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
May 2, 2022
509
Feb 22, 2022 at 11:42 AM
Hi Sheepy,

Here is a different code for you to try:
Sub RunMe()
Dim lRow, x, y As Long
Application.ScreenUpdating = False

lRow = Range("A1").End(xlDown).Row

For x = lRow To 2 Step -1
    y = Cells(x, "J").Value
    Do
        y = y - 1
        Range(Cells(x, "A"), Cells(x, "G")).Copy
        Cells(x + 1, "A").Insert shift:=xlDown
        Range(Cells(x, "I"), Cells(x, "AB")).Copy
        Cells(x + 1, "I").Insert shift:=xlDown
        Cells(x + 1, "H").Insert shift:=xlDown
        Cells(x + 1, "D").Value = "Pallets"
    Loop Until y = 0
    
    y = Cells(x, "G").Value
    Do
        y = y - 1
        Range(Cells(x, "A"), Cells(x, "G")).Copy
        Cells(x + 1, "A").Insert shift:=xlDown
        Range(Cells(x, "I"), Cells(x, "AB")).Copy
        Cells(x + 1, "I").Insert shift:=xlDown
        Cells(x + 1, "H").Insert shift:=xlDown
    Loop Until y = 1

Next x
Application.ScreenUpdating = True
End Sub


Best regards,
Trowa

1
Sheepy_777
Posts
3
Registration date
Wednesday February 16, 2022
Status
Member
Last seen
February 23, 2022

Feb 23, 2022 at 03:28 PM
THANK YOU SO MUCH! i made a couple adjustments to it but it works PERFECTLY!
0
TrowaD
Posts
2880
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
May 2, 2022
509 > Sheepy_777
Posts
3
Registration date
Wednesday February 16, 2022
Status
Member
Last seen
February 23, 2022

Feb 24, 2022 at 11:43 AM
Awesome, thanks for the feedback!
0