Sub style_Summary()
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Call Get_Data ' put all data in one sheet (named "Data")
Call create_summary
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub create_summary()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim InRng As Range
Dim Inarr() As Variant
Dim Outarr() As Variant
'
' idx is array of column numbers to be selected for output (first element of 0 ignored)
'
idx = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 12, 13, 14, 15, 16, 18, 20, 21, 22, 23, 24, 25)
Set ws1 = Worksheets("Data")
Set ws2 = Worksheets("Style Wise Summary")
With ws1
lr = .Cells(Rows.Count, "A").End(xlUp).Row
Inarr = .Range("A2:Y" & lr) ' Assign data to in-memory array
ReDim Outarr(1 To 22, 1 To 1) ' Dimesion to output arrat
Style = Inarr(1, 3) ' First Style
lineID = Inarr(1, 1) ' First Line ID
ns = 1 ' count of styles
r = 1 ' Start index for input array
rr = 0 ' Index for output array
Do Until r > UBound(Inarr, 1) ' Loop through input data
If Inarr(r, 3) = Style And Inarr(r, 1) = lineID Then ' If this is first occurence of a style within a Line Id ....
If ns = 1 Then ' First record for this Line ID/Style
rr = rr + 1
ReDim Preserve Outarr(1 To 22, 1 To rr) ' Redimension output array
For k = 1 To UBound(idx, 1) ' Loop through column indices to create output array
c = idx(k)
Outarr(k, rr) = Inarr(r, c) ' Store first occuence of each variable
Next k
ns = ns + 1
r = r + 1
Else
For k = 11 To UBound(idx, 1) ' Second and subsequent records for this Line ID/Style
j = idx(k)
Outarr(k, rr) = Outarr(k, rr) + Inarr(r, j) ' Accumulate totals
Next k
ns = ns + 1
r = r + 1
End If
Else
'
' Calculate averages for this Line ID/ Style
'
Outarr(10, rr) = Outarr(10, rr) / ns ' Day Target
Outarr(12, rr) = Outarr(12, rr) / ns ' DHU
Outarr(20, rr) = Outarr(20, rr) / ns ' Efficiency
If Inarr(r, 1) <> lineID Then rr = rr + 1 ' Add "spacer" line if new Line ID
Style = Inarr(r, 3) ' Set next style
lineID = Inarr(r, 1) ' Set next Line ID
ns = 1
End If
Loop
End With
With ws2 ' sheet "Style wise Summary"
.Range("A4:V1000").ClearContents ' Clear the outpur range
.Cells(4, "A").Resize(rr, 22) = Application.Transpose(Outarr) ' copy output array to "Style wise Summary"
End With
ws2.Activate
End Sub
Sub Get_Data()
'
' Get_data Macro
'
Dim Inarr() As Variant
Dim InRng As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim Current As Worksheet
Dim Cmonth As String
Set ws1 = Worksheets("Style Wise Summary")
Set ws2 = Worksheets("Data") ' Collate all data onto this sheet
ws2.Range("A2:Y5000").ClearContents ' clear data Sheet
Cmonth = ws1.Range("A1") ' Month name of tabs
' Loop through all of the worksheets in the active workbook.
nextr = 2
For Each Current In Worksheets
If InStr(1, Current.Name, Cmonth) Then ' If this a "month" sheet then extract data ...
With Current
lr = .Cells(Rows.Count, "A").End(xlUp).Row ' Last row of input sheet
.Range("A4:Y" & lr).Copy
ws2.Range("A" & nextr).PasteSpecial xlPasteValues ' Copy/paste values
nextr = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1 ' Next row in input sheet
End With
End If
Next
ws2.Activate
lr = ws2.Cells(Rows.Count, "A").End(xlUp).Row ' Last row in "Data" tab
'
' Sort by Line ID then Style
'
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Data").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Data").Sort.SortFields.Add Key:=Range("A2:A" & lr) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Data").Sort.SortFields.Add Key:=Range("B2:B" & lr) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Data").Sort
.SetRange Range("A2:Y" & lr)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sheet "Data" is an extract of data from all the sheets (do NOT delete this sheet)
LinkBack URL
About LinkBacks
Summary of daily data based on different criteria
Register To Reply
Originally Posted by JohnTopley
Bookmarks