Here we go :
Sub Test()
Dim rng As Range, arrInput, arrOutput, header, i As Long, j As Long, p As Long
Set rng = Range("A1").CurrentRegion
arrInput = rng.Value
ReDim arrOutput(1 To UBound(arrInput) * 166, 1 To 6)
p = 1
For i = 2 To UBound(arrInput, 1)
For j = 6 To UBound(arrInput, 2)
p = p + 1
arrOutput(p, 1) = arrInput(i, 1)
arrOutput(p, 2) = arrInput(i, 2)
arrOutput(p, 3) = arrInput(i, 3)
arrOutput(p, 4) = arrInput(i, 4)
arrOutput(p, 5) = arrInput(1, j)
arrOutput(p, 6) = arrInput(i, j)
Next j
Next i
header = Array("Acount Manager", "Area", "Zone", "Description", "Customer ID", "Contract")
For j = 0 To UBound(header): arrOutput(1, j + 1) = header(j): Next j
rng.Offset(rng.Rows.Count + 2).Resize(UBound(arrOutput, 1), UBound(arrOutput, 2)) = arrOutput
End Sub
Regards
Bookmarks