Macro to move data

[o2coolchris]

I need help designing a macro that can take data that comes in looking like this...

A - B - C - D - E - F - G
123 - 5 e. main st. - Anytown - IL - 60635 - emp1 - john smith1
123 - 5 e. main st. - Anytown - IL - 60635 - emp2 - john smith2
123 - 5 e. main st. - Anytown - IL - 60635 - emp3 - john smith3
123 - 5 e. main st. - Anytown - IL - 60635 - emp4 - john smith4
123 - 5 e. main st. - Anytown - IL - 60635 - emp5 - john smith5
321 - 1 e. main st. - Anytown - IL - 60635 - emp1 - john smith6
321 - 1 e. main st. - Anytown - IL - 60635 - emp2 - john smith7
321 - 1 e. main st. - Anytown - IL - 60635 - emp3 - john smith8
321 - 1 e. main st. - Anytown - IL - 60635 - emp4 - john smith9
321 - 1 e. main st. - Anytown - IL - 60635 - emp5 - john smith0

and moves and filters it so that it looks like this...

H - I - J - K - L - M - N - O - P - Q
- - - - - emp1 - emp2 - emp3 - emp4 -emp5
123 - 5 e. main - town - IL - zip - smith1 - smith2 - smith3 - smith4 - smith5
321 - 1 e main - town - IL - zip - smith6 - smith7 - smith8 - smith9 - smith0


So in the initial column F, the employee #s 1-5 will be constant throughout every set that comes in. Each set is 5 rows, and the number of sets varies from day to day. So I need the macro to move the data from the first 5 rows, and then the next 5 rows after that, and the 5 after that one, etc... basically until there is no more data (upto the blank row)

I have a basic "Copy this, paste it transposed here and advanced filter this and paste it here" kind of macro, but as it stands now, it repeats the code 60 times so it can handle 60 sets of data. As you can imagine, this is very slow.

If you need to see that code, i can post it, but i'd rather start from scratch on this one.

Thank yoU!

 

[Fazza]

Hi Chris. For your source data starting in cell "A1" try this. Modify to suit as required. Regards, Fazza

Sub test()
    Dim arInput As Variant
    Dim arOutput As Variant
    Dim i As Long
    Dim j As Long
    
    With Range("A1").CurrentRegion.Resize(, 7)
        ReDim arInput(1 To .Rows.Count, 1 To 7)
        ReDim arOutput(1 To .Rows.Count / 5, 1 To 10)
        arInput = .Value2
        For i = LBound(arOutput) To UBound(arOutput)
            For j = 1 To 5
                arOutput(i, j) = arInput(i * 5, j)
                arOutput(i, j + 5) = arInput(i * 5 + j - 5, 7)
            Next j
        Next i
    End With
    Range("H1").Resize(UBound(arOutput), 10).Value2 = arOutput
End Sub