• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Macro for transposing and re-arranging data set

O

Oxidised

Member
Hi all,
I'm reposting this from <here> to the Macro forum as I believe it needs a macro solution.

Bascially, what I need to do is transpose and re-align a messy set of data from the "Data" tab of the attached sheet into the tab "Mailmerge". The format on the Mailmerge tab is how I need it to look to match my mail merge document that this data will feed into.
Underlying reasons for this are: mailmerge requires a certain format and only handles 1 email address in the field, the source data changes frequently and we only want to send one email to each customer.

My macro syntax knowledge is not good, so I was hoping someone might be able to take the "logic" I have written below and turn it into macro code for me?
The logic of the macro needs to do the following:

Code: 
Sub funky fix up data macro
- clear all existing data on "mailmerge" (except the header row)
- determine the number of columns in data tab 
- loop for each column:
  - determine if the company name is same as previous column
    - if no
      - check if "more email flag" is set
        - if yes
          - loop for each additional email address:
            - copy complete last row and paste on next row
            - copy next email address into Column D
            - check if another email address
          - end loop
          - clear "more email flag"
        - end if
        - move to next row and increment ID number (column A)
        - copy company name (row1), contact (row2) , email (row6), terms (row4) from Data to Mailmerge2 (columns B - E)
        - assign today's date to (Column F)
        - copy product (row12), del/pickup (row10), and location (row11) from Data to Mailmerge2 (columns G - I)
        - lookup today's price and copy to (column J)
        - check if there are further email addresses in rows (7-9):
          - if yes, set a variable "more emails flag" with number of extra email address and cell reference
      - end if
      - next loop
    - if yes
      - loop for each column of same company name
        - copy product (row12), del/pickup (row10), and location (row11) from Data to Mailmerge2 (next 3 columns)
        - lookup today's price and copy to (next column)
      - end loop
  - end loop
- end sub

This macro will get run once per day. It is Ok if it is not the fastest macro, I prefer it to be clear so I can maintain it. Currently the task of sending out 130+ emails takes ~2 HOURS, so a macro + mail merge that takes ~5mins will be a HUGE improvement in our system.

Thanks in advance for all the help.
Regards, Oxi
 

Attachments

  • CALC-CWPs chandoo.xlsx
    97.2 KB · Views: 6
Last edited:
Hi,
See suggestion in the attached file. I've used a custom class to handle all those data.
Macro is in the module call "M_MailMerge". You will also need the 2 classes "cCustomer" and "cCustomers".
 

Attachments

  • CALC-CWPs chandoo.xlsm
    116.3 KB · Views: 3
@GCExcel
WOW!! thanks GC Excel, that is amazing! I would never have known to work through a class based array like that.
I have been plugging away trying to make it work on a straight copy/paste each cell process... which is mostly working, but was struggling with section on multiple emails... and I haven't been able to get the lookup of the date yet. I'll keep going just to see if I can do it, but your code seems to be much more streamlined and will probably use that. I think I understand how most of it works. Only issue is maintaining it in the future...

Thanks again :DD

One question on your code. In the section where you find the row for today's date, how would I make it so there is a pop-up entry box so the user can input a date, which is then matched to the row. There may be a case where they want to run the macro for yesterday, or last Friday or some such.

Code: 
        'Find today's row (if not found, take the last one)
        Set rg = .Range("A13:A" & .Range("A60000").End(xlUp).Row)
        For Each c In rg
            If c.Value = Date Then DateRow = c.Row: Exit For
        Next c
        If DateRow = 0 Then DateRow = .Range("A60000").End(xlUp).Row
 
I figured out how to get an input for the date working, and used your section of code above to search for the date.

Updated file with both macros in it. I think the give the same results!

my code as below. it is long and messy!
Code: 
Sub CreateMailMerge()
'
' CreateMailMerge Macro
' takes info from wsData tab and generates the list ready for mail merge
'

Application.ScreenUpdating = False
'-----------------------------------------------
' define variables

' define worksheets
Dim wsData As Worksheet
Dim wsMailMerge As Worksheet
Set wsData = Feuil1
Set wsMailMerge = Feuil2

' define and set common variables
Dim i As Integer ' used for the main loop
Dim j As Integer ' used for company loop
Dim m As Integer ' used for email loop
Dim DateReqd As Date ' used to store the date of the mail merge
Dim NumEmails As Integer ' used to track how many emails for each company
Dim IDnum As Integer ' for mail merge ID number
Dim ColDataOffset As Integer ' used to offset the number of columns in wsData sheet to account for extra information
Dim ColDataLast As Integer ' used to find the last column in the wsData sheet
Dim ColData ' the number of columns that we will loop for
Dim ColCurrent As Integer ' used to track which column is being read from wsData sheet
Dim ColPrevious As Integer ' used to track the last column reference in wsData sheet
Dim RowMergeOffset As Integer ' used to offset the rows in the wsMailMerge worksheet
Dim RowCurrent As Integer ' tracks which row we are up to in wsMailMerge sheet
Dim RowPrevious As Integer ' tracks the previous row in wsMailMerge sheet

DateReqd = InputBox("please input required date in format dd/mm/yyyy")
'DateReqd = "02/05/2014"
NumEmails = 1
IDnum = 1
ColDataOffset = 1
wsData.Activate
ColDataLast = Range("zz1").End(xlToLeft).Column
ColData = ColDataLast - ColDataOffset
ColCurrent = 1 + ColDataOffset
ColPrevious = ColCurrent - 1
RowMergeOffset = 1
RowCurrent = 1 + RowMergeOffset - 1
RowPrevious = RowCurrent - 1

' define the rows as taken from the wsData sheet
Dim RowCustomer As Integer
Dim RowTerms As Integer
Dim RowContact As Integer
Dim RowEmailstart As Integer
Dim RowEmailend As Integer
Dim RowPickDel As Integer
Dim RowLocation As Integer
Dim RowProduct As Integer

RowCustomer = 1
RowTerms = 4
RowContact = 5
RowEmailstart = 6
RowEmailend = 9
RowPickDel = 10
RowLocation = 11
RowProduct = 12

' define and set columns for the wsMailMerge sheet
Dim ColID As Integer
Dim ColCustomer As Integer
Dim ColContact As Integer
Dim ColEmail As Integer
Dim ColTerms As Integer
Dim ColDate As Integer
Dim ColProduct As Integer
Dim ColPickDel As Integer
Dim ColLocation As Integer
Dim ColPrice As Integer
Dim Coloffset As Integer

ColID = 1
ColCustomer = 2
ColContact = 3
ColEmail = 4
ColTerms = 5
ColDate = 6
ColProduct = 7
ColPickDel = 8
ColLocation = 9
ColPrice = 10
Coloffset = 4


' variables for checking customers
Dim currentCustomer As String
Dim lastCustomer As String

' variables for looking up the price
Dim RowPrice As Integer
Dim datelookuprange As Range
Dim datelookup As Range

'-----------------------------------------------
' code starts here


' lookup the correct row for pricing by matching the date
wsData.Activate
Set datelookuprange = Range("a16:a" & Range("a65536").End(xlUp).Row)
For Each datelookup In datelookuprange
    If datelookup.Value = DateReqd Then RowPrice = datelookup.Row: Exit For
Next datelookup
If RowPrice = 0 Then RowPrice = Range("B65536").End(xlUp).Row

'error checking to display outputs
'wsMailMerge.Cells(1, 47).Value = RowPrice
'wsMailMerge.Cells(1, 48).Value = DateReqd


' Clear existing wsMailMerge sheet
    wsMailMerge.Activate
    Range("a1", ActiveCell.SpecialCells(xlLastCell)).ClearContents
   
' set up headers on wsMailMerge sheet - to be sure they match separate mail merge document
    Range("a1").Value = "ID"
    Range("b1").Value = "Customer"
    Range("c1").Value = "Contact"
    Range("d1").Value = "Email"
    Range("e1").Value = "Terms"
    Range("f1").Value = "Date"
    Range("g1").Value = "Product1"
    Range("h1").Value = "Pickup/Del1"
    Range("i1").Value = "Location1"
    Range("j1").Value = "Price1"
    Range("k1").Value = "Product2"
    Range("l1").Value = "Pickup/Del2"
    Range("m1").Value = "Location2"
    Range("n1").Value = "Price2"
    Range("o1").Value = "Product3"
    Range("p1").Value = "Pickup/Del3"
    Range("q1").Value = "Location3"
    Range("r1").Value = "Price3"
    Range("s1").Value = "Product4"
    Range("t1").Value = "Pickup/Del4"
    Range("u1").Value = "Location4"
    Range("v1").Value = "Price4"
    Range("w1").Value = "Product5"
    Range("x1").Value = "Pickup/Del5"
    Range("y1").Value = "Location5"
    Range("z1").Value = "Price5"
    Range("aa1").Value = "Product6"
    Range("ab1").Value = "Pickup/Del6"
    Range("ac1").Value = "Location6"
    Range("ad1").Value = "Price6"
    Range("ae1").Value = "Product7"
    Range("af1").Value = "Pickup/Del7"
    Range("ag1").Value = "Location7"
    Range("ah1").Value = "Price7"
    Range("ai1").Value = "Product8"
    Range("aj1").Value = "Pickup/Del8"
    Range("ak1").Value = "Location8"
    Range("al1").Value = "Price8"
    Range("ai1").Value = "Product9"
    Range("aj1").Value = "Pickup/Del9"
    Range("ak1").Value = "Location9"
    Range("al1").Value = "Price9"
   
   
' start main loop
    For i = 1 To ColData
        ' test if customer is the same in this column and the last column
        ' currentCustomer = wsData.Cells(RowCustomer, ColCurrent).Value
        ' lastCustomer = wsData.Cells(RowCustomer, ColCurrent - 1).Value
        ' wsMailMerge.Cells(RowCurrent, 49).Value = currentCustomer & " ~ " & lastCustomer
        ' If currentCustomer <> lastCustomer Then
        If wsData.Cells(RowCustomer, ColCurrent).Value <> wsData.Cells(RowCustomer, ColCurrent - 1).Value Then
            ' If customers are different, then check the number of email addresses
            ' wsMailMerge.Cells(RowCurrent + 1, 45).Value = "different"
            ' set counters
            j = 1
            RowCurrent = RowCurrent + 1
            RowPrevious = RowCurrent - 1
           
            If NumEmails > 1 Then
                For m = 1 To (NumEmails - 1)
                    wsMailMerge.Rows(RowPrevious).Copy Destination:=wsMailMerge.Range("A" & RowCurrent)
                    wsMailMerge.Cells(RowCurrent, ColEmail).Value = wsData.Cells(RowEmailstart + m, ColPrevious).Value
                    'increment counters
                    RowCurrent = RowCurrent + 1
                    RowPrevious = RowCurrent - 1
                Next
                NumEmails = 1
            End If

            ' Copy the generic wsData in the first few columns
            ' set the ID
            wsMailMerge.Cells(RowCurrent, ColID).Value = IDnum
            IDnum = IDnum + 1
            ' copy paste customer
            wsMailMerge.Cells(RowCurrent, ColCustomer).Value = wsData.Cells(RowCustomer, ColCurrent).Value
            ' copy paste Contact
            wsMailMerge.Cells(RowCurrent, ColContact).Value = wsData.Cells(RowContact, ColCurrent).Value
            ' copy paste Email
            wsMailMerge.Cells(RowCurrent, ColEmail).Value = wsData.Cells(RowEmailstart, ColCurrent).Value
            ' copy paste Terms
            wsMailMerge.Cells(RowCurrent, ColTerms).Value = wsData.Cells(RowTerms, ColCurrent).Value
            ' set the date field
            wsMailMerge.Cells(RowCurrent, ColDate).Value = DateReqd
           
            ' Copy paste the product
            wsMailMerge.Cells(RowCurrent, ColProduct).Value = wsData.Cells(RowProduct, ColCurrent).Value
            ' Copy paste the pick up or Delivery
            wsMailMerge.Cells(RowCurrent, ColPickDel).Value = wsData.Cells(RowPickDel, ColCurrent).Value
            ' Copy paste the Location
            wsMailMerge.Cells(RowCurrent, ColLocation).Value = wsData.Cells(RowLocation, ColCurrent).Value
            ' Look up the correct price, then paste
            wsMailMerge.Cells(RowCurrent, ColPrice).Value = wsData.Cells(RowPrice, ColCurrent).Value
           
            ' check if there are extra email addresses
            wsData.Activate
            If WorksheetFunction.CountA(Range(Cells(RowEmailstart, ColCurrent), Cells(RowEmailend, ColCurrent))) > 1 Then
                NumEmails = WorksheetFunction.CountA(Range(Cells(RowEmailstart, ColCurrent), Cells(RowEmailend, ColCurrent)))
            End If
           
            ' temporary print line for testing
            ' wsMailMerge.Cells(RowCurrent, 44).Value = NumEmails
 
            ' increment counters
            ColCurrent = ColCurrent + 1
            ColPrevious = ColCurrent - 1
       
        Else
            ' wsMailMerge.Cells(RowCurrent, 46).Value = "same"
                                 
            ' Copy paste the next product
            wsMailMerge.Cells(RowCurrent, (ColProduct + (j * Coloffset))).Value = wsData.Cells(RowProduct, ColCurrent).Value
            ' Copy paste the next pick up or Delivery
            wsMailMerge.Cells(RowCurrent, (ColPickDel + (j * Coloffset))).Value = wsData.Cells(RowPickDel, ColCurrent).Value
            ' Copy paste the next Location
            wsMailMerge.Cells(RowCurrent, (ColLocation + (j * Coloffset))).Value = wsData.Cells(RowLocation, ColCurrent).Value
            ' Look up the next correct price, then paste
            wsMailMerge.Cells(RowCurrent, (ColPrice + (j * Coloffset))).Value = wsData.Cells(RowPrice, ColCurrent).Value

            ' increment counters
            j = j + 1
            ColCurrent = ColCurrent + 1
            ColPrevious = ColCurrent - 1
       
        End If
    Next
                           
    ' set cursor to home
    wsData.Activate
    Range("a1").Select
    wsMailMerge.Activate
    Range("a1").Select
   
Application.ScreenUpdating = True
MsgBox ("Success - mail list generated")

End Sub
 

Attachments

  • CALC-CWPs chandoo-suggestion.xlsm
    139 KB · Views: 7
You must log in or register to reply here.
Back
Top