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!

 

[mumps]

OK. Give me a little time and I'll get to work on it.

 

[SeanMorrowJ]

Amazing! Thanks so much!!

 

[mumps]

Sorry for the delay. I found it a little tricky. Make sure that Sheet1 is the active sheet and try the following macro:

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

 

[SeanMorrowJ]

Hmm I'm running the Macro but there's nothing happening in Sheet 2. It's working with the example Workbook I uploaded, but when I paste in the real data, there's nothing happening. Any idea?

 

[mumps]

It is always easier to help and test possible solutions if we could work with your actual file. What works with a sample doesn't always work with the actual because even a very minor change will make a difference. Perhaps you could upload a copy of your actual file and post the link here. If the workbook contains confidential information, you could replace it with generic data.

 

[SeanMorrowJ]

That's what I did mumps, I merely changed the name of the headers and I manually introduced some generic data (I'm afraid the real info is confidential). But when I copy the data into the sample workbook or set up the macro you sent me into the workbook with the real data, it appears to do nothing. I'm going to look into it cause it might have to do with the type of data/way of copy pasting, etc. I was just wondering maybe you had any ideas.

Massive thanks so far!!! I'll get back to you, in a few hours.

 

[SeanMorrowJ]

Hahah f***, I'm sorry mumps! It's working just fine! None of the Cells in EK I was trying, had the word YES, so it copied nothing, as it should . Huuuuuge thanks!!!

BTW, Column I may occasionally contain images. It doesn't appear that this new Macro copies them, unlike the first one you posted which I do believe it did. Any thoughts on that?

 

[mumps]

In the file you uploaded, Column I contains only data. Can you upload a copy that also contains the images?

 

[SeanMorrowJ]

OK, here's an example:

http://www.mediafire.com/file/0buyo1w94867v3q/Worksheet_data_example_Macro_with_images_2.xlsm

The images are added in as if it were Insert -> Picture -> (Paste URL).

Aside from the images not getting copied, it seems like after applying the macro, they get distorted/stretched vertically. The images are originally set in place to match the height of the cells.

 

[mumps]

Try this version:

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 = 10
            y = y + 1
        End If
    Next rng
    If Sheets("Sheet1").FilterMode Then Sheets("Sheet1").ShowAllData
    Application.ScreenUpdating = True
End Sub