Macro grouping column data into same row

[SeanMorrowJ]

Hi! I have 2 Worksheets and I’d need a Macro that copies data from “Worksheet 1” to “Worksheet 2”.

I’ve been trying to get it to work via long formulas, but it seems unclean, glitchy and overly complex. So I thought a Macro would be a better option but I’m afraid I’m not too familiar in VBA and so I’d appreciate any help on the matter.

Basically, Column B of Worksheet 1 contains a list of names ordered alphabetically. Many of the names appear more than once, so say B2 = B3 = B4 ≠ B5 ≠ B6 = B7…

Each name contains important data in Columns F, G, H, I, J.

What I’d need the macro to do is to copy the name and important data into Worksheet 2, but grouping into one same row all the data belonging to a certain name.

So for example, the name “John Williams” might appear 3 times in Worksheet 1 (B2, B3, B4) and thus has important data in Cells: F2, F3, F4 & G2, G3, G4 & H2, H3, H4 & I2, I3, I4 & J2, J3, J4.

I need Worksheet 2 to create a row for each name, containing all the important data belonging to that particular name. In Worksheet 2, from the start of one set of data to the next, it’s 7 columns across (J2 -> Q2 -> X2). A certain name will never have more than 32 sets of data.

Here’s an example of how Worksheet 1 looks and how Worksheet 2 should end up after the Macro. (the colors are in there just for guidance, they're not necessary)

Thank you VERY MUCH!

 

[SeanMorrowJ]

I'm afraid I've encountered the following issues with this latest version:

- It copies the images, but it seems to loop endlessly copying images on top of another. On the example Workbook it doesn't, but with the real data it keeps going and going and I'm forced to interrupt the Macro to stop my PC from crashing. Any ideas why this could be?
- Some of the images keep getting stretched vertically.
- Some of the fields in Sheet1, say Column A for instance, are derived from a formula. With this new Macro, what's pasted into Sheet2 is the formula (which makes no sense in that Sheet), instead of the value which is what I actually need. I'm guessing this has to do with the way copy pasting is done in the new macro in order to include the images, but has now affected the rest of the values.

I understand it'd be easier to just send you the Workbook with the actual data, but as I said, I'm afraid it's all highly confidential.

Thanks again mumps. If it's too complex let me know and I'll try to find another solution .

 

[mumps]

Is there any way you could upload a copy of your actual file with just enough data to act as a sample that demonstrates the problem and replace any confidential information with generic data?

 

[SeanMorrowJ]

Is there any way you could upload a copy of your actual file with just enough data to act as a sample that demonstrates the problem and replace any confidential information with generic data?

It seems like I won't be needing the images, so I've been using you second version which works great, thanks again.

Sub Copydata()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
Dim rng2 As Range
Dim x As Long
x = 10
Dim y As Long
y = 2
Dim rngUniques As Range
Sheets("Sheet1").Range("K1:K" & LastRow).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("K1:K" & LastRow), Unique:=True
Set rngUniques = Sheets("Sheet1").Range("K2:K" & LastRow).SpecialCells(xlCellTypeVisible)
If Sheets("Sheet1").FilterMode Then Sheets("Sheet1").ShowAllData
For Each rng In rngUniques
Range("A1:EK" & LastRow).AutoFilter Field:=11, Criteria1:=rng
Range("A1:EK" & LastRow).SpecialCells(xlCellTypeVisible).AutoFilter Field:=141, Criteria1:="=*Yes*"
If ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = rng
For Each rng2 In Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
Sheets("Sheet2").Cells(y, x) = rng2
x = x + 7
Next rng2
x = 11
For Each rng2 In Range("C2:C" & LastRow).SpecialCells(xlCellTypeVisible)
Sheets("Sheet2").Cells(y, x) = rng2
x = x + 7
Next rng2
x = 12
For Each rng2 In Range("EK2:EK" & LastRow).SpecialCells(xlCellTypeVisible)
Sheets("Sheet2").Cells(y, x) = rng2
x = x + 7
Next rng2
x = 14
For Each rng2 In Range("I2:I" & LastRow).SpecialCells(xlCellTypeVisible)
Sheets("Sheet2").Cells(y, x) = rng2
x = x + 7
Next rng2
x = 16
For Each rng2 In Range("V2:V" & LastRow).SpecialCells(xlCellTypeVisible)
Sheets("Sheet2").Cells(y, x) = rng2
x = x + 7
Next rng2
x = 10
y = y + 1
End If
Next rng
If Sheets("Sheet1").FilterMode Then Sheets("Sheet1").ShowAllData
Application.ScreenUpdating = True
End Sub

Lastly, could I have the macro include in the same way, Column EA of Sheet1 into Columns IF, IG, IH, II, etc of Sheet2. I tried editing it a bit but it's not working perfectly as it made a repeating set down Columns Q, R, U.

/...

 For Each rng2 In Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)                Sheets("Sheet2").Cells(y, x) = rng2
                x = x + 7
            Next rng2
            x = 11
            For Each rng2 In Range("C2:C" & LastRow).SpecialCells(xlCellTypeVisible)
                Sheets("Sheet2").Cells(y, x) = rng2
                x = x + 7
            Next rng2
            x = 12
            For Each rng2 In Range("EK2:EK" & LastRow).SpecialCells(xlCellTypeVisible)
                Sheets("Sheet2").Cells(y, x) = rng2
                x = x + 7
            Next rng2
            x = 14
            For Each rng2 In Range("H2:H" & LastRow).SpecialCells(xlCellTypeVisible)
                Sheets("Sheet2").Cells(y, x) = rng2
                x = x + 7
[B]            Next rng2[/B]
[B]            x = 240[/B]
[B]            For Each rng2 In Range("EA2:EA" & LastRow).SpecialCells(xlCellTypeVisible)[/B]
[B]                Sheets("Sheet2").Cells(y, x) = rng2[/B]
[B]                x = x + 1[/B]
            Next rng2
            x = 16
            For Each rng2 In Range("V2:V" & LastRow).SpecialCells(xlCellTypeVisible)
                Sheets("Sheet2").Cells(y, x) = rng2
                x = x + 7
            Next rng2
            x = 10
            y = y + 1
        End If

/...


Any ideas? Thanks mumps!

 

[mumps]

The last version of your file didn't have any data in column EA. It would be easier to test if you could upload a version of your file with data in column EA.

 

[SeanMorrowJ]

The last version of your file didn't have any data in column EA. It would be easier to test if you could upload a version of your file with data in column EA.

I haven't got it on this PC. Could you just add some random data on the one I sent you the other day (

http://www.mediafire.com/file/0buyo1w94867v3q/Worksheet+data+example+Macro+with+images+2.xlsm

)?

It should be pretty straight forward, no? Check out what I added. It's perfect except for the fact that it repeats certain info. I guess cause I'm missing a line or copied it in the wrong place?

Thanks!

 

[mumps]

Try:

Sub Copydata()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim rng As Range
    Dim rng2 As Range
    Dim x As Long
    x = 10
    Dim y As Long
    y = 2
    Dim rngUniques As Range
    Sheets("Sheet1").Range("K1:K" & LastRow).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("K1:K" & LastRow), Unique:=True
    Set rngUniques = Sheets("Sheet1").Range("K2:K" & LastRow).SpecialCells(xlCellTypeVisible)
    If Sheets("Sheet1").FilterMode Then Sheets("Sheet1").ShowAllData
    For Each rng In rngUniques
        Range("A1:EK" & LastRow).AutoFilter Field:=11, Criteria1:=rng
        Range("A1:EK" & LastRow).SpecialCells(xlCellTypeVisible).AutoFilter Field:=141, Criteria1:="=*Yes*"
        If ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
            Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = rng
            For Each rng2 In Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
                rng2.Copy Sheets("Sheet2").Cells(y, x)
                x = x + 7
            Next rng2
            x = 11
            For Each rng2 In Range("C2:C" & LastRow).SpecialCells(xlCellTypeVisible)
                rng2.Copy Sheets("Sheet2").Cells(y, x)
                x = x + 7
            Next rng2
            x = 12
            For Each rng2 In Range("EK2:EK" & LastRow).SpecialCells(xlCellTypeVisible)
                rng2.Copy Sheets("Sheet2").Cells(y, x)
                x = x + 7
            Next rng2
            x = 14
            For Each rng2 In Range("I2:I" & LastRow).SpecialCells(xlCellTypeVisible)
                rng2.Copy Sheets("Sheet2").Cells(y, x)
                x = x + 7
            Next rng2
            x = 16
            For Each rng2 In Range("V2:V" & LastRow).SpecialCells(xlCellTypeVisible)
                rng2.Copy Sheets("Sheet2").Cells(y, x)
                x = x + 7
            Next rng2
            x = 240
            For Each rng2 In Range("EA2:EA" & LastRow).SpecialCells(xlCellTypeVisible)
                Sheets("Sheet2").Cells(y, x) = rng2
                x = x + 1
            Next rng2
            x = 10
            y = y + 1
        End If
    Next rng
    If Sheets("Sheet1").FilterMode Then Sheets("Sheet1").ShowAllData
    Application.ScreenUpdating = True
End Sub

 

[SeanMorrowJ]

Yess, perfect! Thanks for everything mumps!!!!

 

[mumps]

My pleasure.