I have excel sheet with N+1 rows where Column A has unique id N.
I need to duplicate each row so that below a row N there will be three new rows with unique-ids N-b, N-c, N-d
e.g. sample input rows:
id1 data here
id2 data2 here
e.g. sample output:
id1 data here
id1-b data here
id1-c data here
id1-d data here
id2 data2 here
id2-b data2 here
id2-c data2 here
id2-d data2 here
You could try something like this
Sub Macro1()
Dim sheet As Worksheet
Dim usedRange As Range
Set sheet = ActiveSheet
Set usedRange = sheet.usedRange
Dim i As Integer
For i = 1 To usedRange.Rows.Count
Dim row As Range
Set row = usedRange.Rows(((i - 1) * 4) + 1)
Dim iCopy As Integer
For iCopy = 1 To 3
row.Copy
Dim insertRow As Range
Set insertRow = usedRange.Rows(((i - 1) * 4) + 1 + iCopy)
insertRow.insert xlDown
Dim copiedRow As Range
Set copiedRow = usedRange.Rows(((i - 1) * 4) + 1 + iCopy)
copiedRow.Cells(1, 1) = copiedRow.Cells(1, 1) & "-" & Chr(97 + iCopy)
Next iCopy
Next i
End Sub
Range, it's easier to start with the last row/column and work backwards. In this case, it would simplify how to determine where insertRow and copiedRow should beIf I need to know how to do something using VBA, the easiest way to find out is to do it manually and record my actions in a macro. It is then usually a simple procedure to edit the macro to my precise requirements.
I wanted to just duplicate the rows without the hyphen at the end of each copied data item so I omitted the last line from the code
'copiedRow.Cells(1, 1) = copiedRow.Cells(1, 1) & "-" & Chr(97 + iCopy)
It duplicated the rows perfectly, thank you.
Sub Macro4()
'
' Macro4 Macro
'
'
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Dim s3 As Worksheet
Dim rng1 As Range
Set sheet1 = Sheets("Sheet1")
Set sheet2 = Sheets("Sheet2")
Dim empRange As Range
sheet1.Activate
Dim lastRow As Double
lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For Each b In Range("A1:I" & lastRow).Rows
Range("I" & b.Row).FormulaR1C1 = "=COUNT(RC[-4]:RC[-2])"
Next
Range("A1:I" & lastRow).AutoFilter Field:=9, Criteria1:="=2", _
Operator:=xlOr, Criteria2:="=3"
Set rng1 = sheet1.Range(sheet1.[a2], sheet1.Cells(Rows.Count, "A").End(xlUp))
rng1.Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Set A = Selection
Dim sheet2_last_row As Long
Dim empRecordCount As Long
For Each b In A.Rows
sheet1.Activate
courseKey = sheet1.Cells(b.Row, 1).Value
catA = Cells(b.Row, 5).Value
catB = Cells(b.Row, 6).Value
catC = Cells(b.Row, 7).Value
MsgBox courseKey & "-" & catA & "-" & catB & "-" & catC
'apply auto filter on sheet 2 by course key
sheet2.Activate
Range("a1").Select
Selection.AutoFilter Field:=2, Criteria1:=courseKey
ActiveCell.Offset(1, 0).Cells.Select
MsgBox "1"
empRecordCount = Selection.SpecialCells(xlCellTypeVisible).Rows.Count
'if found,
If empRecordCount > 0 Then
MsgBox "records found"
'Check whether its first non empty category
isFirstCategory = True
Set empRange = sheet2.Range(Selection.Cells, sheet2.Cells(sheet2.Rows.Count, "A").End(xlUp))
empRange.Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Set empRecord = Selection
Set s3 = Sheets("Sheet3")
s3.Activate
s3.Cells.ClearContents
empRecord.Copy Destination:=s3.Cells(1, "A")
MsgBox "2"
Set s3_range = s3.Cells(1, "A")
s3_range.Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Set s3_records = Selection
MsgBox "3"
'check whether catA is blank then set value in category column
If catA <> "" Then
sheet2.Activate
Range("a1").Select
Selection.AutoFilter Field:=2, Criteria1:=courseKey
MsgBox "111"
Set empRange = sheet2.Range(Selection.Cells, sheet2.Cells(sheet2.Rows.Count, "A").End(xlUp))
empRange.Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
MsgBox "2222"
Set empRecord = Selection
For Each e In empRecord.Rows
sheet2.Activate
sheet2.Cells(e.Row, 4).Value = "A"
sheet2.Cells(e.Row, 5).Value = catA
Next
isFirstCategory = False
End If
'check catB is not blank. copy searched row rom shee 2 and insert it below change category column with Cat B
If catB <> "" Then
If isFirstCategory Then
sheet2.Activate
Set empRecord = Selection
For Each e In empRecord.Rows
sheet2.Activate
sheet2.Cells(e.Row, 4).Value = "B"
sheet2.Cells(e.Row, 5).Value = catB
Next
Else
s3.Activate
If empRecordCount > 1 Then
Set s3_range = s3.Cells(1, "A")
s3_range.Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Set s3_records = Selection
For Each e In s3_records.Rows
s3.Cells(e.Row, 4).Value = "B"
s3.Cells(e.Row, 5).Value = catB
Next
Else
s3.Cells(1, 4).Value = "B"
s3.Cells(1, 5).Value = catB
End If
sheet2.Activate
sheet2.Cells(1, "A").Select
Selection.AutoFilter
MsgBox "4"
sheet2_last_row = sheet2.Cells(sheet2.Rows.Count, "A").End(xlUp).Row
s3_records.Copy Destination:=sheet2.Cells(sheet2_last_row + 1, "A")
End If
End If
'check catC is not blank. copy searched row rom shee 2 and insert it below change category column with Cat C
If catC <> "" Then
If isFirstCategory Then
sheet2.Activate
Set empRecord = Selection
For Each e In empRecord.Rows
sheet2.Activate
sheet2.Cells(e.Row, 4).Value = "C"
sheet2.Cells(e.Row, 5).Value = catC
Next
Else
s3.Activate
If empRecordCount > 1 Then
Set s3_range = s3.Cells(1, "A")
s3_range.Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Set s3_records = Selection
For Each e In s3_records.Rows
s3.Cells(e.Row, 4).Value = "C"
s3.Cells(e.Row, 5).Value = catC
Next
Else
s3.Cells(1, 4).Value = "C"
s3.Cells(1, 5).Value = catC
End If
sheet2.Activate
sheet2.Cells(1, "A").Select
Selection.AutoFilter
MsgBox "5"
sheet2_last_row = sheet2.Cells(sheet2.Rows.Count, "A").End(xlUp).Row
s3_records.Copy Destination:=sheet2.Cells(sheet2_last_row + 1, "A")
End If
End If
End If
s3.Activate
s3.Cells.ClearContents
Next
sheet1.Activate
sheet1.Cells.Select
Selection.AutoFilter
sheet2.Activate
sheet2.Cells.Select
Selection.AutoFilter
End Sub
