Sub newRow() Dim lstRow, lstrow1 As Long Dim i, j, k As Integer Dim Str1, Str2 As String lstRow = Range("A" & Rows.Count).End(xlUp).Row For i = 1 To lstRow Str1 = Cells(i, 1).Value For j = 2 To Columns.Count Str2 = Cells(i, j).Value If Str2 <> "" Then lstrow1 = Worksheets(2).Range("A" & Rows.Count).End(xlUp).Row Worksheets(2).Cells(lstrow1, 1).Offset(1, 0).Value = Str1 Worksheets(2).Cells(lstrow1, 2).Offset(1, 0).Value = Str2 Else: GoTo 1 End If Next j 1: Next i End Sub
DON'T MISS