Macro to move stuff around (awesome title I know :P)

youra6

Board Regular
Joined
Mar 31, 2014
Messages
95
I have a macro that lets me take a customer contact list and change it into this format. I initially thought this format would work well with index(match), but it doesn't.

Here is it:

ClientContactPhone # (Office)Phone # (Mobile)Email AddressNotesClientContactPhone # (Office)Phone # (Mobile)Email AddressNotesClientContactPhone # (Office)Phone # (Mobile)Email AddressNotes
WalmartName 1111-111-1111111-111-1112name1@email.comWalmartName 2222-222-2222222-222-2223Name3@email.comCostcoName 3333-333-3333333-333-3334name3@gmail.comblah blah

<tbody>
</tbody>


This table continues in this format until column PV, and it subject to be longer as time goes on. For now, I only included the first 3 clients.

As you can tell, it follows a simple pattern. On every 7th column, it goes back to Client and loops the same column headers.

I want a Macro that turns the above table into this:

ClientContactPhone # (Office)Phone # (Mobile)Email AddressNotesClientContactPhone # (Office)Phone # (Mobile)Email AddressNotes
WalmartName 1111-111-1111111-111-1112name1@email.comWalmartName 2222-222-2222222-222-2223Name3@email.com
ClientContactPhone # (Office)Phone # (Mobile)Email AddressNotes
CostcoName 3333-333-3333333-333-3334name3@gmail.comblah blah

<tbody>
</tbody>


Everytime a new Client is introduced, it is given its own row (Costo is different from Walmart and Walmart).


I then can proceed to create a macro to delete the duplicate headers, so the end result would look like this and it would be way easier to do my index match formulas:

ClientContactPhone # (Office)Phone # (Mobile)Email AddressNotesClientContactPhone # (Office)Phone # (Mobile)Email AddressNotes
WalmartName 1111-111-1111111-111-1112name1@email.comWalmartName 2222-222-2222222-222-2223Name3@email.com
CostcoName 3333-333-3333333-333-3334name3@gmail.comblah blah

<tbody>
</tbody>
 

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney
Try Something like the below code. I had trouble figuring out a way to define parameters for when new client information started and ended so I decided to put them in array. As long as you update the Array with the New Customers this will do the trick. I left it to include multiple headers. If you don't want multiple header let me know and I can tweak it differently.

Code:
[COLOR=#0000ff]Sub[/COLOR] MoveData()

  [COLOR=#0000ff]  Dim[/COLOR] LastRow          [COLOR=#0000ff] As Long[/COLOR]
  [COLOR=#0000ff]  Dim[/COLOR] i                [COLOR=#0000ff] As Variant[/COLOR]
   [COLOR=#0000ff] Dim[/COLOR] Rng              [COLOR=#0000ff] As[/COLOR] Range
  [COLOR=#0000ff]  Dim [/COLOR]FirstAddress      [COLOR=#0000ff]As String[/COLOR]
  [COLOR=#0000ff]  Dim[/COLOR] LastAddress      [COLOR=#0000ff] As String[/COLOR]
   [COLOR=#0000ff] Dim[/COLOR] OffLastAddress    [COLOR=#0000ff]As String[/COLOR]
    [COLOR=#0000ff]Dim[/COLOR] OffFirstAddress   [COLOR=#0000ff]As String[/COLOR]
    
[COLOR=#008000]    'Define Customer Array[/COLOR]
    CustArray = Array("Walmart", "Costco", "[COLOR=#ff0000]Add Next Customer Here[/COLOR]")
    
    For i = LBound(CustArray) To UBound(CustArray)
    LastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
[COLOR=#008000]    'Count Number of Contacts By Counting Customer Occurrence[/COLOR]
    CountArrayItem = Application.WorksheetFunction.CountIf(Range(Cells(2, 1), Cells(2, Columns.Count)), CustArray(i))
    
[COLOR=#008000]    'Find First Instance of Client[/COLOR]
 [COLOR=#0000ff]   With [/COLOR]Sheets("Sheet1").Range("B2:B" & Columns.Count)
       [COLOR=#0000ff]Set[/COLOR] Rng = Cells.Find(What:=CustArray(i), _
                       After:=Range("A1"), _
                       LookAt:=xlWhole, _
                       LookIn:=xlValues, _
                       SearchOrder:=xlByColumns, _
                       SearchDirection:=xlNext, _
                       MatchCase:=[COLOR=#0000ff]False[/COLOR])
[COLOR=#0000ff]    End With[/COLOR]
                   [COLOR=#0000ff] If Not[/COLOR] Rng [COLOR=#0000ff]Is Nothing Then
[/COLOR]                    FirstAddress = Rng.Address
                    OffFirstAddress = Range(FirstAddress).Offset(-1).Address
                   [COLOR=#0000ff] End If[/COLOR]
[COLOR=#008000]    'Find Last Instance of Client[/COLOR]
   [COLOR=#0000ff] With[/COLOR] Sheets("Sheet1").Range("B2:B" & Columns.Count)
       [COLOR=#0000ff]Set[/COLOR] Rng = Cells.Find(What:=CustArray(i), _
                       After:=Range("A1"), _
                       LookAt:=xlWhole, _
                       LookIn:=xlValues, _
                       SearchOrder:=xlByColumns, _
                       SearchDirection:=xlPrevious, _
                       MatchCase:=[COLOR=#0000ff]False[/COLOR])
[COLOR=#0000ff]    End With[/COLOR]
                   [COLOR=#0000ff] If Not [/COLOR]Rng [COLOR=#0000ff]Is Nothing Then[/COLOR]
                    LastAddress = Rng.Address
                    OffLastAddress = Range(LastAddress).Offset(, 5).Address
[COLOR=#0000ff]                    End If[/COLOR]
[COLOR=#008000]    'Check To Make Sure This Is Not the First Client.  So We Do Not Duplicate Info...[/COLOR]
   [COLOR=#0000ff] If Not [/COLOR]OffFirstAddress = "$A$1" [COLOR=#0000ff]Then[/COLOR]
[COLOR=#008000]    'Paste Client Contact Data in Next Available Row[/COLOR]
    Range(OffFirstAddress & ":" & OffLastAddress).Cut Destination:=Sheets("Sheet1").Cells(LastRow + 1, 1)
[COLOR=#0000ff]    End If[/COLOR]

   [COLOR=#0000ff] Next[/COLOR] i

[COLOR=#0000ff]End Sub[/COLOR]
 
Last edited:
Upvote 0
Try Something like the below code. I had trouble figuring out a way to define parameters for when new client information started and ended so I decided to put them in array. As long as you update the Array with the New Customers this will do the trick. I left it to include multiple headers. If you don't want multiple header let me know and I can tweak it differently.

Code:
[COLOR=#0000ff]Sub[/COLOR] MoveData()

  [COLOR=#0000ff]  Dim[/COLOR] LastRow          [COLOR=#0000ff] As Long[/COLOR]
  [COLOR=#0000ff]  Dim[/COLOR] i                [COLOR=#0000ff] As Variant[/COLOR]
   [COLOR=#0000ff] Dim[/COLOR] Rng              [COLOR=#0000ff] As[/COLOR] Range
  [COLOR=#0000ff]  Dim [/COLOR]FirstAddress      [COLOR=#0000ff]As String[/COLOR]
  [COLOR=#0000ff]  Dim[/COLOR] LastAddress      [COLOR=#0000ff] As String[/COLOR]
   [COLOR=#0000ff] Dim[/COLOR] OffLastAddress    [COLOR=#0000ff]As String[/COLOR]
    [COLOR=#0000ff]Dim[/COLOR] OffFirstAddress   [COLOR=#0000ff]As String[/COLOR]
    
[COLOR=#008000]    'Define Customer Array[/COLOR]
    CustArray = Array("Walmart", "Costco", "[COLOR=#ff0000]Add Next Customer Here[/COLOR]")
    
    For i = LBound(CustArray) To UBound(CustArray)
    LastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
[COLOR=#008000]    'Count Number of Contacts By Counting Customer Occurrence[/COLOR]
    CountArrayItem = Application.WorksheetFunction.CountIf(Range(Cells(2, 1), Cells(2, Columns.Count)), CustArray(i))
    
[COLOR=#008000]    'Find First Instance of Client[/COLOR]
 [COLOR=#0000ff]   With [/COLOR]Sheets("Sheet1").Range("B2:B" & Columns.Count)
       [COLOR=#0000ff]Set[/COLOR] Rng = Cells.Find(What:=CustArray(i), _
                       After:=Range("A1"), _
                       LookAt:=xlWhole, _
                       LookIn:=xlValues, _
                       SearchOrder:=xlByColumns, _
                       SearchDirection:=xlNext, _
                       MatchCase:=[COLOR=#0000ff]False[/COLOR])
[COLOR=#0000ff]    End With[/COLOR]
                   [COLOR=#0000ff] If Not[/COLOR] Rng [COLOR=#0000ff]Is Nothing Then
[/COLOR]                    FirstAddress = Rng.Address
                    OffFirstAddress = Range(FirstAddress).Offset(-1).Address
                   [COLOR=#0000ff] End If[/COLOR]
[COLOR=#008000]    'Find Last Instance of Client[/COLOR]
   [COLOR=#0000ff] With[/COLOR] Sheets("Sheet1").Range("B2:B" & Columns.Count)
       [COLOR=#0000ff]Set[/COLOR] Rng = Cells.Find(What:=CustArray(i), _
                       After:=Range("A1"), _
                       LookAt:=xlWhole, _
                       LookIn:=xlValues, _
                       SearchOrder:=xlByColumns, _
                       SearchDirection:=xlPrevious, _
                       MatchCase:=[COLOR=#0000ff]False[/COLOR])
[COLOR=#0000ff]    End With[/COLOR]
                   [COLOR=#0000ff] If Not [/COLOR]Rng [COLOR=#0000ff]Is Nothing Then[/COLOR]
                    LastAddress = Rng.Address
                    OffLastAddress = Range(LastAddress).Offset(, 5).Address
[COLOR=#0000ff]                    End If[/COLOR]
[COLOR=#008000]    'Check To Make Sure This Is Not the First Client.  So We Do Not Duplicate Info...[/COLOR]
   [COLOR=#0000ff] If Not [/COLOR]OffFirstAddress = "$A$1" [COLOR=#0000ff]Then[/COLOR]
[COLOR=#008000]    'Paste Client Contact Data in Next Available Row[/COLOR]
    Range(OffFirstAddress & ":" & OffLastAddress).Cut Destination:=Sheets("Sheet1").Cells(LastRow + 1, 1)
[COLOR=#0000ff]    End If[/COLOR]

   [COLOR=#0000ff] Next[/COLOR] i

[COLOR=#0000ff]End Sub[/COLOR]

I'll give this a whirl, thank you so much. Also looks like a honker of a macro...
 
Upvote 0
If you want to get rid of the headers just add these few lines below
Code:
[COLOR=#0000ff]Next[/COLOR] i
in the above procedure

So the end of the procedure would now look like this:

Code:
  [COLOR=#0000ff]If Not[/COLOR] OffFirstAddress = "$A$1" [COLOR=#0000ff]Then[/COLOR]
    Range(OffFirstAddress & ":" & OffLastAddress).Cut Destination:=Sheets("Sheet1").Cells(LastRow + 1, 1)
[COLOR=#0000ff]    End If[/COLOR]

  [COLOR=#0000ff]  Next [/COLOR]i
[COLOR=#008000]
'Clean up Headers[/COLOR]
[COLOR=#0000ff]For[/COLOR] i = LastRow + 2 [COLOR=#0000ff]To [/COLOR]2 [COLOR=#0000ff]Step[/COLOR] -1
   [COLOR=#0000ff] If [/COLOR]Range("A" & i).Value = "Client" [COLOR=#0000ff]Then[/COLOR] Rows(i).Delete
[COLOR=#0000ff]Next [/COLOR]i[COLOR=#0000ff]
[/COLOR]
[COLOR=#0000ff]End Sub[/COLOR]
 
Upvote 0
If you want to get rid of the headers just add these few lines below
Code:
[COLOR=#0000ff]Next[/COLOR] i
in the above procedure

So the end of the procedure would now look like this:

Code:
  [COLOR=#0000ff]If Not[/COLOR] OffFirstAddress = "$A$1" [COLOR=#0000ff]Then[/COLOR]
    Range(OffFirstAddress & ":" & OffLastAddress).Cut Destination:=Sheets("Sheet1").Cells(LastRow + 1, 1)
[COLOR=#0000ff]    End If[/COLOR]

  [COLOR=#0000ff]  Next [/COLOR]i
[COLOR=#008000]
'Clean up Headers[/COLOR]
[COLOR=#0000ff]For[/COLOR] i = LastRow + 2 [COLOR=#0000ff]To [/COLOR]2 [COLOR=#0000ff]Step[/COLOR] -1
   [COLOR=#0000ff] If [/COLOR]Range("A" & i).Value = "Client" [COLOR=#0000ff]Then[/COLOR] Rows(i).Delete
[COLOR=#0000ff]Next [/COLOR]i[COLOR=#0000ff]
[/COLOR]
[COLOR=#0000ff]End Sub[/COLOR]

That would save me the trouble of running another macro. Thanks!
 
Upvote 0
Glad I got you all sorted out. This one took some thought! Thanks for the learning opportunity.

Sorry to bother you again, but there is a small problem after I added in a column making it a total of 7 (instead of 6 previously).

So I looked at your code and changed one small part (changed the 5 to a 6 at the bottom):

Code:
Sub MoveDataIntoRows()


    Dim LastRow           As Long
    Dim i                 As Variant
    Dim Rng               As Range
    Dim FirstAddress      As String
    Dim LastAddress       As String
    Dim OffLastAddress    As String
    Dim OffFirstAddress   As String
    
    'Define Customer Array
    CustArray = Array("Alliance Berstein", "Amur Capital", "Cantor Fitzgerald / BGC - Data", "Cantor Fitzgerald / BGC - Voice", "Direct Edge", "CSN (Companhia Siderurgica Nacional)", "International Trading Group / DETrading", "ITHS", "Lord Abbett", "Lucera", "Morgan Stanley", "Nasdaq", "NYSE / NYFIX", "Prometheus Global Media", "Scoria - Same as Weeden", "Société Générale", "Société Générale Europe", "Weeden & Co")
    
    For i = LBound(CustArray) To UBound(CustArray)
    LastRow = Sheets("Macro Sheet").Range("A" & Rows.Count).End(xlUp).Row
    'Count Number of Contacts By Counting Customer Occurrence
    CountArrayItem = Application.WorksheetFunction.CountIf(Range(Cells(2, 1), Cells(2, Columns.Count)), CustArray(i))
    
    'Find First Instance of Client
    With Sheets("Macro Sheet").Range("B2:B" & Columns.Count)
       Set Rng = Cells.Find(What:=CustArray(i), _
                       After:=Range("A1"), _
                       LookAt:=xlWhole, _
                       LookIn:=xlValues, _
                       SearchOrder:=xlByColumns, _
                       SearchDirection:=xlNext, _
                       MatchCase:=False)
    End With
                    If Not Rng Is Nothing Then
                    FirstAddress = Rng.Address
                    OffFirstAddress = Range(FirstAddress).Offset(-1).Address
                    End If
    'Find Last Instance of Client
    With Sheets("Macro Sheet").Range("B2:B" & Columns.Count)
       Set Rng = Cells.Find(What:=CustArray(i), _
                       After:=Range("A1"), _
                       LookAt:=xlWhole, _
                       LookIn:=xlValues, _
                       SearchOrder:=xlByColumns, _
                       SearchDirection:=xlPrevious, _
                       MatchCase:=False)
    End With
                    If Not Rng Is Nothing Then
                    LastAddress = Rng.Address
                    OffLastAddress = Range(LastAddress).Offset(, [COLOR=#ff0000][SIZE=4][B]6[/B][/SIZE][/COLOR]).Address
                    End If
    'Check To Make Sure This Is Not the First Client.  So We Do Not Duplicate Info...
    If Not OffFirstAddress = "$A$1" Then
    'Paste Client Contact Data in Next Available Row
    Range(OffFirstAddress & ":" & OffLastAddress).Cut Destination:=Sheets("Macro Sheet").Cells(LastRow + 1, 1)
    End If


    Next i
    'Clean up Headers
For i = LastRow + 2 To 2 Step -1
    If Range("A" & i).Value = "Client" Then Rows(i).Delete
Next i


End Sub


I changed that number to a 6 thinking it would fix it. And it did for the most part. However, there is only one customer who has 6 contacts. The first 5 are in their correct location. However the 6th contact is stuck all the way in Cell BS1 (the original location before the Macro).

To test it, I deleted the 6th contact, and the macro works flawlessly. So essentially, any client with > 6 contacts breaks this code.

Its not a big deal because I can manually Cut and Paste this to the right location, but its bugging me why its breaking the code.

If you have the time to teach, I would love to learn. :)
 
Last edited:
Upvote 0

Forum statistics

Threads
1,207,011
Messages
6,076,143
Members
446,187
Latest member
LMill

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top