Moving data from a row to column based on dup

**scooby103** · 12-31-2010, 11:48 AM

Originally Posted by jeffreybrown

So are you saying you would like Frank to move to D2, Johnson to E1, Tammy to F1, Tam to G1 and so on?

Essentially, but it needs to be based on the Company Name. So, if the same company exists grab the other contact information from the duplicate company and plug it into blank contact firstname2, etc. If the company doesn't exist don't do anything and move to next down the row.

Tks,

**jeffreybrown** · 12-31-2010, 11:56 AM

I'll give it a go

**scooby103** · 12-31-2010, 11:58 AM

Originally Posted by jeffreybrown

I'll give it a go

Thanks Jeffrey - appreciated!!

**jeffreybrown** · 12-31-2010, 01:21 PM

Here you go...sorry it took so long. I really stuggle when a macro involves the moving of cells, but I think this does it.

If you want to delete all of the blanks thereby leaving just the unique company names then remove the " ' " from the code below.

I duplicated your data on Sheet2 and Sheet3 if you want to run it without the delete and then with. Hope this is what you expected.

>> To run the macro from Excel, ALT + F8 Highlight macro and select Run

Sub MoveData()
    Dim LR As Long
    Dim i As Long
    Dim j As Long: j = 4
    LR = Range("A" & Rows.Count).End(xlUp).Row
    For i = 3 To LR
        If Cells(i - 1, 1) <> Cells(i - 2, 1) Then
            Cells(i, 2).Resize(, 2).Copy Cells(i - 1, j)
            Cells(i + 1, 2).Resize(, 2).Copy Cells(i - 1, j + 2)
        End If
    Next i
    'Deletes all blank rows which do not have names leaving just one unique company name
    'Range("D:D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete xlShiftUp
End Sub

**scooby103** · 12-31-2010, 02:32 PM

Originally Posted by jeffreybrown

Here you go...sorry it took so long. I really stuggle when a macro involves the moving of cells, but I think this does it.

If you want to delete all of the blanks thereby leaving just the unique company names then remove the " ' " from the code below.

I duplicated your data on Sheet2 and Sheet3 if you want to run it without the delete and then with. Hope this is what you expected.

>> To run the macro from Excel, ALT + F8 Highlight macro and select Run

Sub MoveData()
    Dim LR As Long
    Dim i As Long
    Dim j As Long: j = 4
    LR = Range("A" & Rows.Count).End(xlUp).Row
    For i = 3 To LR
        If Cells(i - 1, 1) <> Cells(i - 2, 1) Then
            Cells(i, 2).Resize(, 2).Copy Cells(i - 1, j)
            Cells(i + 1, 2).Resize(, 2).Copy Cells(i - 1, j + 2)
        End If
    Next i
    'Deletes all blank rows which do not have names leaving just one unique company name
    'Range("D:D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete xlShiftUp
End Sub

Hey Jeff,

Thanks! I'm trying to run the macro as you stated above but when I hit Alt F8 there is no macro to run. I'm using Excel 2010, could that be the issue?

How can I cut / paste your code above into Excel to run it?

Tks,

**jeffreybrown** · 12-31-2010, 02:49 PM

I don't have 2010 so I'm not sure on in being compatible, but my guess should work the same.

Sorry I forgot to attach the workbook

•Highlight macro >> press >> CTRL + C
•Open your workbook
•Press >> ALT + F11 >> opens the Visual Basic Editor (VBE)
•Press >> ALT + I >> activates the Insert menu
•Press >> M >> inserts a Standard Module
•Paste code >> CTRL + V (right side of screen)
•Press >> ALT + Q >> exits VBE and returns to Excel
•Run the macro >> press >> ALT + F8 >> displays Macro Dialog Box. Highlight macro >> select Run.

**scooby103** · 12-31-2010, 03:03 PM

Originally Posted by jeffreybrown

I don't have 2010 so I'm not sure on in being compatible, but my guess should work the same.

Sorry I forgot to attach the workbook

•Highlight macro >> press >> CTRL + C
•Open your workbook
•Press >> ALT + F11 >> opens the Visual Basic Editor (VBE)
•Press >> ALT + I >> activates the Insert menu
•Press >> M >> inserts a Standard Module
•Paste code >> CTRL + V (right side of screen)
•Press >> ALT + Q >> exits VBE and returns to Excel
•Run the macro >> press >> ALT + F8 >> displays Macro Dialog Box. Highlight macro >> select Run.

Your a genius!

However... I do have other data that would need to be moved when it does the move besides First / Last Name. I need to also move email, phone and title. I have included what my template looks like with some fake data, if you could fix this you would move from Genius to Rock Star! - Oh, and there are 3500 rows of data... not sure if that matters to your macro or not. I have put column headers for up to 4 contacts per company. If there would be a way to create the columns as needed (more then 4 contacts per company) that would be amazing.... otherwise any more then 4 can be ignored / deleted.