Option Explicit
Sub CustDates()
Dim lr As Long, i As Long, j As Long
lr = Range("B" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
j = 6
For i = 4 To lr 'You may wish to test on a smaller number by changing lr to maybe 7 or 8 . Be sure to change back once satisfied.
Range("B" & i).Copy Cells(4, j + 1)
Range("D4:D246").Copy Cells(4, j)
Cells(4, j + 1).Copy Range(Cells(5, j + 1), Cells(246, j + 1))
j = j + 3
Next i
Application.ScreenUpdating = True
Application.CutCopyMode = False
MsgBox "complete"
End Sub
Sub Demo1()
Dim Rg As Range, R&
[G3].CurrentRegion.Offset(1).Clear
Application.ScreenUpdating = False
R = 4
With Range("D4", [D3].End(xlDown))
For Each Rg In Range("B4", [B3].End(xlDown))
Rg.Copy Cells(R, 7).Resize(.Count)
R = R + .Count
Next
.Copy Range("H4", Cells(R - 1, 8))
End With
Application.ScreenUpdating = True
End Sub
Sub shashwatAgarwal()
Dim Cl As Range, Rng As Range
Set Rng = Range("D4", Range("D" & Rows.Count).End(xlUp))
Range("G3:H3").Value = Array("Customer Codes", "Dates")
For Each Cl In Range("B4", Range("B" & Rows.Count).End(xlUp))
Cl.Copy Range("G" & Rows.Count).End(xlUp).Offset(1).Resize(Rng.Count)
Rng.Copy Range("H" & Rows.Count).End(xlUp).Offset(1)
Next Cl
End Sub
Sub Test()
Dim a, b, i As Long, j As Long, k As Long
a = Range("B4", Range("B" & Rows.Count).End(xlUp)).Value
b = Range("D4", Range("D" & Rows.Count).End(xlUp)).Value
ReDim c(1 To UBound(a) * UBound(b), 1 To 2)
For i = LBound(a) To UBound(a)
For j = LBound(b) To UBound(b)
k = k + 1
c(k, 1) = a(i, 1)
c(k, 2) = b(j, 1)
Next j
Next i
Range("J3").Resize(1, 2).Value = Array("Customer Codes", "Dates")
Range("J4").Resize(UBound(c, 1), UBound(c, 2)).Value = c
End Sub
You're welcome & thanks for the feedbackThank you so much Fluff13