1. Computer problem? Tech Support Guy is completely free -- paid for by advertisers and donations. Click here to join today! If you're new to Tech Support Guy, we highly recommend that you visit our Guide for New Members.

Excel macro - multiple rows to single row

Discussion in 'Business Applications' started by Barnsley, Aug 29, 2017.

Thread Status:
Not open for further replies.
  1. Barnsley

    Barnsley Thread Starter

    Joined:
    Aug 29, 2017
    Messages:
    1
    Hello!

    I wonder if someone could help me? I'm trying to combine multiple rows into a single row. My data currently is formatted:

    E-mail,First Name,Last Name,Event,Ticket Name,Spaces
    [email protected],John,Taylor,C,81,5
    [email protected],Mary,Smith,A,81,2
    [email protected],Mary,Smith,D,144,1
    [email protected],Mary,Smith,I,81,1
    [email protected],Mary,Smith,G,82,1
    [email protected],John,Taylor,A,81,2

    I'd like to be able to combine rows so that my data looks like this:

    E-mail,First Name,Last Name,Event,Ticket Name,Spaces,Event,Ticket Name,Spaces,Event,Ticket Name,Spaces,Event,Ticket Name,Spaces
    [email protected],John,Taylor,C,81,5,A,81,2
    [email protected],Mary,Smith,A,81,2,D,144,1,I,81,1,G,82,1

    I found a macro on an old techguy thread which just about does the job, only it keeps repeating the last name and doesn't reprint the header. I've tried to edit it but I know nothing of Visual Basic and can't figure out how it's working. Here's the code from that thread:

    Code:
    Sub test()
    MainSheetRows = Range("B" & Rows.Count).End(xlUp).Row
    For Each Cell In Range("B1:B" & MainSheetRows)
    x = WorksheetFunction.CountIf(Range("New!B:B"), Cell)
    If x = 0 Then
    y = WorksheetFunction.CountA(Rows(Cell.Row))
    Cell.Offset(, -1).Resize(, y).Copy Sheets("New").Range("A" & Rows.Count).End(xlUp).Offset(1)
    Else
    y = WorksheetFunction.CountA(Rows(Cell.Row)) - 2
    z1 = Application.Match(Cell, Range("New!B:B"), 0)
    z2 = WorksheetFunction.CountA(Sheets("New").Rows(z1))
    Cell.Offset(, 1).Resize(, y).Copy Sheets("New").Cells(z1, z2 + 1)
    End If
    Next Cell
    End Sub
    Is anyone able to help? I've attached a spreadsheet with my test data the above macro.

    Many thanks!
     

    Attached Files:

  2. Keebellah

    Keebellah Trusted Advisor

    Joined:
    Mar 27, 2008
    Messages:
    6,560
    First Name:
    Hans
    Code:
    Sub test()
    Dim MainSheetRows   As Long
    Dim HeaderRow       As Long
    Dim x               As Long
    Dim y               As Long
    Dim z1              As Long
    Dim z2              As Long
    Dim cell            As Range
    
    MainSheetRows = Range("B" & Rows.Count).End(xlUp).Row
    For Each cell In Range("B1:B" & MainSheetRows)
        x = WorksheetFunction.CountIf(Range("New!B:B"), cell)
        If x = 0 Then
            y = WorksheetFunction.CountA(Rows(cell.Row))
            cell.Offset(, -1).Resize(, y).Copy Sheets("New").Range("A" & Rows.Count).End(xlUp).Offset(1)
        Else
            y = WorksheetFunction.CountA(Rows(cell.Row)) - 2
            z1 = Application.Match(cell, Range("New!B:B"), 0)
            z2 = WorksheetFunction.CountA(Sheets("New").Rows(z1))
            cell.Offset(, 2).Resize(, y + 1).Copy Sheets("New").Cells(z1, z2 + 1)
        End If
    Next cell
    End Sub
    
    
    Remains the issue for the header row but you'll work it out :)
     
  3. Keebellah

    Keebellah Trusted Advisor

    Joined:
    Mar 27, 2008
    Messages:
    6,560
    First Name:
    Hans
    Always dim you variables, it's good policy and makes sure you have the correct values
     
As Seen On
As Seen On...

Welcome to Tech Support Guy!

Are you looking for the solution to your computer problem? Join our site today to ask your question. This site is completely free -- paid for by advertisers and donations.

If you're not already familiar with forums, watch our Welcome Guide to get started.

Join over 733,556 other people just like you!

Loading...
Thread Status:
Not open for further replies.

Short URL to this thread: https://techguy.org/1195458

  1. This site uses cookies to help personalise content, tailor your experience and to keep you logged in if you register.
    By continuing to use this site, you are consenting to our use of cookies.
    Dismiss Notice