CODEWITHSUNDEEP
excelvba
WKI
WKI

Reputation: 215

A loop to duplicate rows based on column value

I want to duplicate rows if the value in qty column in grater than 1. It should be duplicated the number of times the value in the cell is. I then want to copy the results in a different sheet and edit the qty column. The code below does it but the header of the qty column is changed. How do I fix this and make it a bit more efficient?

Option Explicit

Sub generateDups()
    Worksheets("Sheet2").Columns(1).ClearContents
    Worksheets("Sheet2").Columns(2).ClearContents
    Worksheets("Sheet2").Columns(3).ClearContents
    Worksheets("Sheet2").Columns(4).ClearContents

    Dim xRow As Long
    Dim inNum As Variant
    xRow = 1

    Do While (Cells(xRow, "A") <> "")
        inNum = Cells(xRow, "D")
        If ((inNum > 1) And IsNumeric(inNum)) Then
            Range(Cells(xRow, "A"), Cells(xRow, "D")).Copy
            Range(Cells(xRow + 1, "A"), Cells(xRow + inNum - 1, "D")).Select
            Selection.Insert Shift:=xlDown
            xRow = xRow + inNum - 1
        End If
        xRow = xRow + 1
    Loop

    copyAndEdit
End Sub



Sub copyAndEdit()
    Dim cValue As String
    Dim rowIndex As Integer
    Dim destRow As Integer
    Dim lastRow As Long, lastCol As Long
    Dim srcSheet As Worksheet
    Dim destSheet As Worksheet

    Set srcSheet = ThisWorkbook.Worksheets("Sheet1")
    Set destSheet = ThisWorkbook.Worksheets("Sheet2")
    destRow = 0
    
    With srcSheet
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column

        For rowIndex = 1 To lastRow
            cValue = .Cells(rowIndex, 2).Value
            destRow = destRow + 1
            destSheet.Cells(destRow, 1) = .Cells(rowIndex, 1)
            destSheet.Cells(destRow, 2) = .Cells(rowIndex, 2)
            destSheet.Cells(destRow, 3) = .Cells(rowIndex, 3)
            destSheet.Cells(destRow, 4) = .Cells(rowIndex, 4) 
        Next rowIndex
    End With
        
    Set srcSheet = Nothing

    With destSheet
        destRow = 0
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column

        For rowIndex = 1 To lastRow
            destRow = destRow + 1
            If destSheet.Cells(destRow, 4).Value > 1 Then
                destSheet.Cells(destRow, 4).Value = 1
            Else
                destSheet.Cells(destRow, 4).Value = .Cells(rowIndex, 4).Value
            End If
        Next rowIndex
        
    End With
        
    Set destSheet = Nothing
End Sub

Current data:

enter image description here

What I am getting:

enter image description here

Expected:

enter image description here

Upvotes: 4

Views: 310

Answers (1)

Wizhi
Wizhi

Reputation: 6549

This part cause the issue since you are writing over the header in the second part of your code:

destRow = 0

'.....

For rowIndex = 1 To lastRow
    destRow = destRow + 1
    If destSheet.Cells(destRow, 4).Value > 1 Then
        destSheet.Cells(destRow, 4).Value = 1

So you set the destRow to be 0 (i.e. destRow = 0). In the first iteration it will be row 1 (destRow = destRow + 1 -> destRow = 1). And since the cell return a value greater than 1 beacuse it's not empty or have a 0 in the cell, it will print 1 in the first row (i.e "Qty" will be overwritten).

One way (if you always going to have numeric values) is to use Isnumeric like this (replace this part If destSheet.Cells(destRow, 4).Value > 1 Then):

If IsNumeric(destSheet.Cells(destRow, 4).Value) > 1 Then

Another way is to skip the first header is by ignoring first row in iteration:

If destSheet.Cells(destRow, 4).Value > 1 And destRow <> 1 Then 'Could be >1 also

Side note, I would also use sheet reference on this part and also declare the sheet1:

Do While (srcSheet.Cells(xRow, "A") <> "")

Upvotes: 2

Related Questions