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

Y

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:

[TABLE="class: grid, width: 1781"]
<tbody>[TR]
[TD]Client[/TD]
[TD]Contact[/TD]
[TD]Phone # (Office)[/TD]
[TD]Phone # (Mobile)[/TD]
[TD]Email Address[/TD]
[TD]Notes[/TD]
[TD]Client[/TD]
[TD]Contact[/TD]
[TD]Phone # (Office)[/TD]
[TD]Phone # (Mobile)[/TD]
[TD]Email Address[/TD]
[TD]Notes[/TD]
[TD]Client[/TD]
[TD]Contact[/TD]
[TD]Phone # (Office)[/TD]
[TD]Phone # (Mobile)[/TD]
[TD]Email Address[/TD]
[TD]Notes[/TD]
[/TR]
[TR]
[TD]Walmart[/TD]
[TD]Name 1[/TD]
[TD]111-111-1111[/TD]
[TD]111-111-1112[/TD]
[TD]name1@email.com[/TD]
[TD][/TD]
[TD]Walmart[/TD]
[TD]Name 2[/TD]
[TD]222-222-2222[/TD]
[TD]222-222-2223[/TD]
[TD]Name3@email.com[/TD]
[TD][/TD]
[TD]Costco[/TD]
[TD]Name 3[/TD]
[TD]333-333-3333[/TD]
[TD]333-333-3334[/TD]
[TD]name3@gmail.com[/TD]
[TD]blah blah[/TD]
[/TR]
</tbody>[/TABLE]


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:

[TABLE="class: grid, width: 1327"]
<tbody>[TR]
[TD]Client[/TD]
[TD]Contact[/TD]
[TD]Phone # (Office)[/TD]
[TD]Phone # (Mobile)[/TD]
[TD]Email Address[/TD]
[TD]Notes[/TD]
[TD]Client[/TD]
[TD]Contact[/TD]
[TD]Phone # (Office)[/TD]
[TD]Phone # (Mobile)[/TD]
[TD]Email Address[/TD]
[TD]Notes[/TD]
[/TR]
[TR]
[TD]Walmart[/TD]
[TD]Name 1[/TD]
[TD]111-111-1111[/TD]
[TD]111-111-1112[/TD]
[TD]name1@email.com[/TD]
[TD][/TD]
[TD]Walmart[/TD]
[TD]Name 2[/TD]
[TD]222-222-2222[/TD]
[TD]222-222-2223[/TD]
[TD]Name3@email.com[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Client[/TD]
[TD]Contact[/TD]
[TD]Phone # (Office)[/TD]
[TD]Phone # (Mobile)[/TD]
[TD]Email Address[/TD]
[TD]Notes[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Costco[/TD]
[TD]Name 3[/TD]
[TD]333-333-3333[/TD]
[TD]333-333-3334[/TD]
[TD]name3@gmail.com[/TD]
[TD]blah blah[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


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:

[TABLE="class: grid, width: 1327"]
<tbody>[TR]
[TD]Client[/TD]
[TD]Contact[/TD]
[TD]Phone # (Office)[/TD]
[TD]Phone # (Mobile)[/TD]
[TD]Email Address[/TD]
[TD]Notes[/TD]
[TD]Client[/TD]
[TD]Contact[/TD]
[TD]Phone # (Office)[/TD]
[TD]Phone # (Mobile)[/TD]
[TD]Email Address[/TD]
[TD]Notes[/TD]
[/TR]
[TR]
[TD]Walmart[/TD]
[TD]Name 1[/TD]
[TD]111-111-1111[/TD]
[TD]111-111-1112[/TD]
[TD]name1@email.com[/TD]
[TD][/TD]
[TD]Walmart[/TD]
[TD]Name 2[/TD]
[TD]222-222-2222[/TD]
[TD]222-222-2223[/TD]
[TD]Name3@email.com[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Costco[/TD]
[TD]Name 3[/TD]
[TD]333-333-3333[/TD]
[TD]333-333-3334[/TD]
[TD]name3@gmail.com[/TD]
[TD]blah blah[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Sort by date Sort by votes
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
mrmmickle1 said:
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]
Click to expand...

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
mrmmickle1 said:
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]
Click to expand...

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

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
You must log in or register to reply here.

Similar threads

R
  • Question Question
Copying from one worksheet to another with added complications
Replies
0
Views
549
rnewton
R
L
  • Question Question
How can I split datas in vertical into column
Replies
2
Views
244
LesterRonquillo
L
M
  • Question Question
VLookup formula and #N/A
Replies
8
Views
816
philwojo
P
WarPigl3t
  • Question Question
Printing causing Out of Memory
Replies
1
Views
285
WarPigl3t
WarPigl3t
H
  • Question Question
Creating a new table from data in another table (and auto entry upon modification)
Replies
1
Views
361
bschwartz
B

Forum statistics

Threads
1,225,768
Messages
6,186,921
Members
453,387
Latest member
uzairkhan

Share this page

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