I would like to write a macro to copy a cell value to a new row.
Example
acol1 acol2 acol3 acol4 acol5 acol6 acol7
bcol1 bcol2 bcol3 bcol4 bcol5 bcol6
ccol1 ccol2 ccol3 ccol4 ccol5 ccol6 ccol7
dcol1 dcol2 dcol3 dcol4 dcol5
i would like to do sth that all the cell from col6 to col9 will go to the new row with other values remain the same.
The result will be sth like
acol1 acol2 acol3 acol4 acol5
acol1 acol2 acol3 acol4 acol6
acol1 acol2 acol3 acol4 acol7
bcol1 bcol2 bcol3 bcol4 bcol5
bcol1 bcol2 bcol3 bcol4 bcol6
ccol1 ccol2 ccol3 ccol4 ccol5
ccol1 ccol2 ccol3 ccol4 ccol6
ccol1 ccol2 ccol3 ccol4 ccol7
dcol1 dcol2 dcol3 dcol4 dcol5
Here is my code
Sub ArrangeTool()
Dim NoOfRecord As Integer
NoOfRecord = ActiveSheet.UsedRange.Rows.Count
For i = 1 To NoOfRecord
For j = 6 To 10
If Not IsEmpty(Cells(i, j)) Then
Cells(i, 1).EntireRow.Insert Shift:=xlUp
If (j = 6) Then
Cells(i + 1, 1).Value = Cells(i, 1).Value + "A"
ElseIf (j = 7) Then
Cells(i + 1, 1).Value = Cells(i, 1).Value + "B"
ElseIf (j = 8) Then
Cells(i + 1, 1).Value = Cells(i, 1).Value + "C"
ElseIf (j = 9) Then
Cells(i + 1, 1).Value = Cells(i, 1).Value + "D"
ElseIf (j = 10) Then
Cells(i + 1, 1).Value = Cells(i, 1).Value + "E"
End If
Cells(i + 1, 2).Value = Cells(i, 2).Value
Cells(i + 1, 3).Value = Cells(i, 3).Value
Cells(i + 1, 4).Value = Cells(i, 4).Value
Cells(i + 1, 5).Value = Cells(i, 5).Value
Cells(i + 1, 6).Value = Cells(i, j).Value
End If
Next j
Next i
End Sub
I dont know why there will be many blank rows created and the content of the file will be displayed after the blank rows..... but i dont know how to correct it, pls help.
Bookmarks