Rearrange a set of data - Nearly there but need help

[ashleyuk1984]

Hi,
I have a set of data that I would like to rearrange into a different format.

I've created a dummy spreadsheet showing a small section of the raw data, and also the desired result on a separate tab.
My current Macro will run on Sheet 3.


The data set is split into sections, by month.
So, the first section starts at January, then February, then March, then April ... And then next month the data set will include May, then June and so on.

http://i63.tinypic.com/14v5kaq.jpg



Within each month section, we have a bunch of companies.... and some of these are repeated every month, some are not. ABC might be in January / February and April (not March), and XYZ might only be in April.


http://i67.tinypic.com/23tnvi1.png


On the right hand side of the dataset, we have a bunch of 'codes'.
And this is the stuff that we need to use to sort out the companies.


http://i65.tinypic.com/30hrl35.png


This is what I'm trying to achieve.


http://i65.tinypic.com/dgl28p.png


But this is what I'm currently getting.


http://i63.tinypic.com/14qtso.png


All of my months are going on seperate rows, but I need to match the company name and code before placing the months. (so if it already exists, just place the month on that row, otherwise create a new record at the bottom)
I'm unsure of the best way to do it.

My complete data set is around 100,000 rows... So ideally, I need to avoid using loops on this amount of rows, otherwise it's going to take forever to complete :(

Here is my current code. It will also be in the attached file.




'########################################################################## ##
'###### DONT DELETE THE HEADINGS... THESE ARE SET UP IN THE MACRO YET #######
'########################################################################## ##


Sub SortData()
Dim Lastrow, x As Long
Dim MonthName As String
Dim CodeNumbers As Variant


'Get LastRow of Raw Data sheet
Lastrow = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row


'Loop through Raw Data and sort it out into the desired format
For x = 2 To Lastrow
LastRowSheet3 = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row
MonthName = Sheets(1).Range("A" & x).Value
CompanyName = Sheets(1).Range("C" & x).Value
CodeNumbers = Sheets(1).Range("J" & x & ":CA" & x)
TestForCode = CodeNumbers(1, 1)

'1 to 70 because Column CA represents 70 (J = 1 ---> CA = 70)
For y = 1 To 70
If CodeNumbers(1, y) = Empty Then Exit For
Sheets(3).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = CompanyName
Sheets(3).Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = Application.Transpose(CodeNumbers(1, y))

If MonthName = "January" Then
Sheets(3).Range("B" & Rows.Count).End(xlUp).Offset(0, 1).Value = MonthName
ElseIf MonthName = "February" Then
Sheets(3).Range("B" & Rows.Count).End(xlUp).Offset(0, 2).Value = MonthName
ElseIf MonthName = "March" Then
Sheets(3).Range("B" & Rows.Count).End(xlUp).Offset(0, 3).Value = MonthName
ElseIf MonthName = "April" Then
Sheets(3).Range("B" & Rows.Count).End(xlUp).Offset(0, 4).Value = MonthName
ElseIf MonthName = "May" Then
Sheets(3).Range("B" & Rows.Count).End(xlUp).Offset(0, 5).Value = MonthName
ElseIf MonthName = "June" Then
Sheets(3).Range("B" & Rows.Count).End(xlUp).Offset(0, 6).Value = MonthName
ElseIf MonthName = "July" Then
Sheets(3).Range("B" & Rows.Count).End(xlUp).Offset(0, 7).Value = MonthName
ElseIf MonthName = "August" Then
Sheets(3).Range("B" & Rows.Count).End(xlUp).Offset(0, 8).Value = MonthName
ElseIf MonthName = "September" Then
Sheets(3).Range("B" & Rows.Count).End(xlUp).Offset(0, 9).Value = MonthName
ElseIf MonthName = "October" Then
Sheets(3).Range("B" & Rows.Count).End(xlUp).Offset(0, 10).Value = MonthName
ElseIf MonthName = "November" Then
Sheets(3).Range("B" & Rows.Count).End(xlUp).Offset(0, 11).Value = MonthName
ElseIf MonthName = "December" Then
Sheets(3).Range("B" & Rows.Count).End(xlUp).Offset(0, 12).Value = MonthName
End If

Next y


Next x

'Sort the data, first by Company Name, then by Code
Range("A1").CurrentRegion.Select
ActiveWorkbook.Worksheets("Macro Runs Here").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Macro Runs Here").AutoFilter.Sort.SortFields.Add Key:=Range("A2:A168"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Macro Runs Here").AutoFilter.Sort.SortFields.Add Key:=Range("B2:B168"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Macro Runs Here").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

End Sub



Here is the spreadsheet
19458

If all goes well, your results and the data on the "Desired Result" sheet should match.

Hope you can help.
Thanks

[mdmackillop]

Give this a try. The final month allocation to be completed.

Option Explicit


Sub Test()
Dim rNames As Range, rCodes As Range
Dim wsRD As Worksheet, wsT As Worksheet
Dim Rw, Col
Dim dic, x, y, k
Dim i As Long
Dim cel As Range, c As Range


Set dic = CreateObject("Scripting.dictionary")
Set wsRD = Sheets("Raw Data")
Set wsT = Sheets.Add
Rw = LR(wsRD, 3)
Col = LC(wsRD, 1)


With wsRD
Set rNames = Range(.Cells(2, 3), .Cells(Rw, 3))
Set rCodes = Range(.Cells(2, 10), .Cells(Rw, Col))


For Each cel In rNames.Cells
For Each c In Range(.Cells(cel.Row, 10), .Cells(cel.Row, LC(wsRD, cel.Row)))
x = cel & "|" & c
y = cel.Offset(, -2)
If Not dic.exists(x) Then
dic.Add x, CStr(y)
Else
dic(x) = dic(x) & "," & y
End If
Next c
Next cel
End With
i = 1
For Each k In dic.keys
i = i + 1
wsT.Cells(i, 1) = Split(k, "|")(0)
wsT.Cells(i, 2) = Split(k, "|")(1)
wsT.Cells(i, 3) = dic(k)
Next k
With wsT
.Sort.SortFields.Add Key:=.Range("A2"), SortOn:=xlSortOnValues, Order:=xlAscending
.Sort.SortFields.Add Key:=.Range("B2"), SortOn:=xlSortOnValues, Order:=xlAscending
With .Sort
.SetRange wsT.Range("A:C")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
End With
End Sub



Function LR(sh, Col) As Long
LR = sh.Cells(Rows.Count, Col).End(xlUp).Row
End Function
Function LC(sh, Rw) As Long
LC = sh.Cells(Rw, Columns.Count).End(xlToLeft).Column
End Function

[ashleyuk1984]

Oh wow, that does the job perfectly. Going to examine that code and see if I can learn something from it.
Thank you

[mdmackillop]

I edited this bit of the code above to show month number instead of month. Which is preferable?

x = cel & "|" & c
y = Month("01 " & cel.Offset(, -2))
If Not dic.exists(x) Then
dic.Add x, CStr(y)
Else
dic(x) = dic(x) & "," & y
End If

[ashleyuk1984]

Hi,
I would prefer the Month Names if possible.
Sorry, I didn't get a chance to save the previous code. My apologises. Could you please post the code with the month names. Again apologises.

[mdmackillop]

Changed above. It requires a simple edit to this line

y = cel.Offset(, -2)

[mdmackillop]

Try this instead of looping through "For K" results to speed things

Dim arr1(), arr2()
arr1 = dic.keys
arr2 = dic.items
Cells(2, 1).Resize(UBound(arr1)) = Application.Transpose(arr1)
Cells(2, 3).Resize(UBound(arr1)) = Application.Transpose(arr2)
Cells(2, 1).Resize(UBound(arr1)).TextToColumns Destination:=Range("A2"), _
DataType:=xlDelimited, OtherChar:="|"
wsT.Range("A:C").Columns.AutoFit

[Bob Phillips]

You could put it in Power Query, unpivot the codes, and then run a simple pivot table. No code, more maintainable.