Help with looping autofilter macro to copy and paste data

[Coyotex3]

Hello guys once again, I'm trying to work on a macro that helps me accomplish the following.

Book1
	A	B	C	D	E	F	G	H	I
1	City	Name					Orders	Order Numbers
2	New York	James A					01- James A	1111
3	New York	James B					02- James A	1115
4	New York	James C					03- James A	1117
5	New York	James D					04- James B	2550
6	New York	James E					05- James B	2555
7	New York	James F					06- James B	2560
8	New York	James G					07- James C	127
9	New York	James H					08- James C	128
10	New York	James I					09- James C	129
11
12
Sheet2

I want for this macro to search starting with range("B2") and to look at column G in order to locate all the cells that contain the name in this case "James A" and to then copy the cells in Columns H that contain that value in order to copy and transpose so the final product looks like this

Book1
	A	B	C	D	E	F	G	H	I	J
1	City	Name	First	Second	Third		Orders	Order Numbers
2	New York	James A	1111	1115	1117		01- James A	1111
3	New York	James B	2550	2555	2560		02- James A	1115
4	New York	James C	127	128	129		03- James A	1117
5	New York	James D					04- James B	2550
6	New York	James E					05- James B	2555
7	New York	James F					06- James B	2560
8	New York	James G					07- James C	127
9	New York	James H					08- James C	128
10	New York	James I					09- James C	129
11
12
13
14
15
Sheet2

 

[Coyotex3]

Assuming that the City and Name are in columns A and B of "Sheet1" and the Orders and Order Numbers are in columns A and B of "Sheet2", try this macro:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, sAddr As String, fnd As Range, name As Range, x As Long: x = 1
    Set desWS = Sheets("Sheet1")
    Set srcWS = Sheets("Sheet2")
    LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each name In desWS.Range("B2:B" & LastRow)
        Set fnd = srcWS.Range("A:A").Find(name, LookIn:=xlValues, lookat:=xlPart)
        If Not fnd Is Nothing Then
            sAddr = fnd.Address
            Do
                With desWS
                    .Cells(1, x + 2) = x
                    .Cells(name.Row, .Columns.Count).End(xlToLeft).Offset(0, 1) = fnd.Offset(, 1)
                    x = x + 1
                End With
                Set fnd = srcWS.Range("A:A").FindNext(fnd)
            Loop While fnd.Address <> sAddr
            sAddr = ""
        End If
        x = 1
    Next name
    Application.ScreenUpdating = True
End Sub

This is absolutely brilliant!!!. No idea how it is able to pull that data and transpose it, but it is AMAZING!!

 

[Coyotex3]

Assuming that the City and Name are in columns A and B of "Sheet1" and the Orders and Order Numbers are in columns A and B of "Sheet2", try this macro:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, sAddr As String, fnd As Range, name As Range, x As Long: x = 1
    Set desWS = Sheets("Sheet1")
    Set srcWS = Sheets("Sheet2")
    LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each name In desWS.Range("B2:B" & LastRow)
        Set fnd = srcWS.Range("A:A").Find(name, LookIn:=xlValues, lookat:=xlPart)
        If Not fnd Is Nothing Then
            sAddr = fnd.Address
            Do
                With desWS
                    .Cells(1, x + 2) = x
                    .Cells(name.Row, .Columns.Count).End(xlToLeft).Offset(0, 1) = fnd.Offset(, 1)
                    x = x + 1
                End With
                Set fnd = srcWS.Range("A:A").FindNext(fnd)
            Loop While fnd.Address <> sAddr
            sAddr = ""
        End If
        x = 1
    Next name
    Application.ScreenUpdating = True
End Sub

Hope you or @SQUIDD can help me troubleshoot this.

The codes do not work if the data becomes this.

Book1
	A	B	C
1	Entity	Name
2	Verizon	John Doe
3	Verizon	Jane Doe
4	Verizon	Jack Doe
5	Verizon	Jose Doe
6	Verizon	Jamie Doe
7	Verizon	Jones Doe
8	Verizon	Mike Doe
9	Verizon	Misty Doe
10	Verizon
11	Verizon
12	Verizon
13	Verizon
14	Verizon
15
Sheet5

Book1
	A	B	C
1	Name	Order
2	JOSE DOE	123458
3	JOSE DOE	123473
4	JOSE DOE	123488
5	JOSE DOE	123503
6	Mike Doe	123518
7	MIKE DOE	123533
8	MIKE DOE	123548
9	MIKE DOE	123563
10	Misty Doe	123578
11	Misty Doe	123593
12	Misty Doe	123608
13	Misty Doe	123623
14	John Doe	123638
15	John Doe	123653
16	John Doe	123668
17	John Doe	123683
18	John Doe	123698
19	James Doe	123713
20	James Doe	123728
21	James Doe	123743
22	James Doe	123758
23	James Doe	123773
24	James Doe	123788
25	Jane Doe	123803
26	Jane Doe	123818
27	Jane Doe	123833
28	Jane Doe	123848
29	Jack Doe	123863
30	Jack Doe	123878
31	Jack Doe	123893
32	Jack Doe	123908
33
Sheet6

Cell Formulas
Range	Formula
B3:B32	B3	=B2+15

Is it because the data is unsorted?

Disregard the formula. I only put it there to fill the values.

 

[mumps]

The sorting doesn't matter. This is what I get (changing the sheet names to Sheet5 and Sheet6):

Entity	Name	1	2	3	4	5
Verizon	John Doe	123638	123653	123668	123683	123698
Verizon	Jane Doe	123803	123818	123833	123848
Verizon	Jack Doe	123863	123878	123893	123908
Verizon	Jose Doe	123458	123473	123488	123503
Verizon	Jamie Doe
Verizon	Jones Doe
Verizon	Mike Doe	123518	123533	123548	123563
Verizon	Misty Doe	123578	123593	123608	123623
Verizon
Verizon
Verizon
Verizon
Verizon

The result seems to be what you requested.