Create Sub Sheets From Master

[juan4412]

I have a workbook which has bi-weekly event data being added to it. The data is being added to a worksheet called Full which is a "catch all" of sorts worksheet that contains the data for EVERYTHING and is very hard to read and/or break down, even using a filter. What I need is a macro that will create a worksheet for each SIC Code, and copy the corresponding data for that SIC code to it's appropriate worksheet following the set-up that the 1114 sheet shows.

I have attached a sample workbook which includes junk non-real data and a very very small snippet of the actual data it contains, if someone could assist with this procedure I would greatly greatly appreciate it!!!

Garbage.xlsx

[SamT]

Sheet "FULL" has merged Cells in it. Even if we have to work with this WorkBook, you would have to unmerge the cells in Row 1.

I assume that you do not have control over the sheet and do not have the influence to introduce a better method of Data Input and analysis.

I have a workbook which has bi-weekly event data being added to it.

Please Explain how Data is added, in full detail.



While others here may know a method of working with the original FULL sheet using Pivot tables, Slicers, or whatever, I am merely a VBA person.

The solution I see, given the sparse information provided, is to first transfer the data to a helper sheet thusly:

		SIC Code	Arrived	Event 1	ETCETERA
1/1/2015	Athlete A	1114	X	X
1/1/2015	Athlete B	1114	X	X
1/1/2015	Athlete C	2219	X	X
1/1/2015	Athlete D	2219	X	X
1/1/2015	Athlete E	2230	X
1/1/2015	Athlete F	2230	X	X
1/1/2015	Athlete G	2230	X	X
1/15/2015	Athlete A	1114	X	X
1/15/2015	Athlete B	1114	X	X
1/15/2015	Athlete C	2219	X	X
1/15/2015	Athlete D	2219	X	X
1/15/2015	Athlete E	2230	X
1/15/2015	Athlete F	2230	X	X
1/15/2015	Athlete G	2230	X	X

This would allow Sorting and Filtering, and greatly facilitate any other Data Analysis.

[juan4412]

Correct, I do not have control over the set-up. How the data gets added, let's take Athlete A for example, for 01/01/2015 Athlete A arrived for events so an "X" was added in C3 which is the corresponding cell for 01/01/2015, attended and Athlete A. An "X" was also added in D3 signifying that Athlete A participated in Event 1, the remaining Event cells for 01/01/015 do not have an "X" for Athlete A signifying Athlete A did not participate in any other events. Cell K3 holds a numeric value (score) which is the total score that Athlete A received for all events participated for 01/01/2015. --- Same cadence is true for the other dates as well as other Athletes listed. Does that help clarify that portion?

[SamT]

How are the X'es added. Do you Manually add therm to your sheet. Do you receive a new "FULL" sheet.

After further thought, Once the Helper sheet is set up, it will be easy to transfer data to it by searching for dates in the top row.

[juan4412]

Yes, the "X" are manually added to the sheet for each corresponding date.

[SamT]

Will you be able to use the table format I posted in Post #2, Or do you need it set up like in your Attachment sheetsd (1114 to 2230?)

If the latter, can you move the Date Columns after the Participation+Score Column?

[juan4412]

Unfortunately, the formatting needs to mirror the attachment sheets.

[jo15765]

Unfortunately, the formatting needs to mirror the attachment sheets.

Using a dictionary this is pretty close to what you are after, just doesn't add the total rows at the end or add the borders as your workbook shows --- see if you can tweak it to add the additional

[vba]
Sub DDDDD()
test
AddTotal
End Sub
Sub test()
Dim a, i As Long, ii As Long, iii As Long, dic As Object
a = Sheets("all").[a3].CurrentRegion.Value
Set dic = CreateObject("Scripting.Dictionary")
dic.Comparemode = 1
For i = 3 To UBound(a, 1)
If Not dic.exists(a(i, 2)) Then
Set dic(a(i, 2)) = CreateObject("Scripting.Dictionary")
End If
For ii = 3 To UBound(a, 2) Step 9
If Not dic(a(i, 2)).exists(a(1, ii)) Then
Set dic(a(i, 2))(a(1, ii)) = CreateObject("Scripting.Dictionary")
End If
For iii = 0 To 7
If Not dic(a(i, 2))(a(1, ii)).exists(a(i, 1)) Then
dic(a(i, 2))(a(1, ii))(a(i, 1)) = Empty
End If
On Error Resume Next
If a(i, ii + iii) = "X" Then
On Error Resume Next
dic(a(i, 2))(a(1, ii))(a(i, 1)) = dic(a(i, 2))(a(1, ii))(a(i, 1)) + 1
End If
Next
Next
Next
SendToWS dic
End Sub

Private Sub SendToWS(dic As Object)
Dim e, i As Long, w
For Each e In dic
If Not IsSheetExists(CStr(e)) Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = CStr(e)
End If
With Sheets(CStr(e))
.Cells(1).CurrentRegion.Clear
.Cells(1, 2).Resize(, dic(e).Count).Value = dic(e).keys
.Cells(2, 1).Resize(dic(e).items()(1).Count).Value = _
Application.Transpose(dic(e).items()(0).keys())
For i = 0 To dic(e).Count - 1
If UBound(dic(e).items()(i).items) > -1 Then
.Cells(2, 2 + i).Resize(dic(e).items()(i).Count).Value = _
Application.Transpose(dic(e).items()(i).items)
End If
Next
.Cells(1).CurrentRegion.Columns.AutoFit
End With
Next
End Sub

Function IsSheetExists(ByVal txt As String) As Boolean
On Error Resume Next
IsSheetExists = Len(Sheets(txt).Name)
On Error GoTo 0
End Function
Sub AddTotal()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim LastRow As Long
Dim LastColLetter As String
Dim LastColLetter2 As String
Dim LastColumn As Long
Dim lastColumn2 As Long
For Each ws In Sheets
If ws.Name <> "All" Then
LastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastColumn = ws.Cells.Find(What:="*", after:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
lastColumn2 = ws.Cells.Find(What:="*", after:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
ws.Cells(1, LastColumn + 1) = "Total"
LastColLetter = Replace(ws.Cells(1, LastColumn + 1).Address(False, False), "1", "")
LastColLetter2 = Replace(ws.Cells(1, LastColumn).Address(False, False), "1", "")
On Error Resume Next
ws.UsedRange.Offset(1, 0).Cells.SpecialCells(xlCellTypeBlanks).Value = 0
ws.Range(LastColLetter & 2 & ":" & LastColLetter & LastRow).Formula = "=sum(B2:" & LastColLetter2 & "2)"
With ws.Range(LastColLetter & 1 & ":" & LastColLetter & LastRow).Borders
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlMedium
End With
With ws
.Columns(LastColLetter).HorizontalAlignment = xlCenter
End With
End If
Next ws
Application.ScreenUpdating = True
End Sub


[/vba]

[juan4412]

Any chance you could give me the syntax to add the totals and formatting? I am no bueno with VBA @ all.