Solved: creating recap with macro

[reza_doang]

hi all,

i have a worksheet with many rows.
i have column with
A(Propinsi) B(Kabupaten) C(Kecamatan) D(Desa)

in that worksheet assume i have many propinsi (A, B, C, D) and every propinsi have many kabupaten and every kabupaten have many kecamatan and every kecamatan have many Desa.
now i need a recap for that file.

i attach my file as example, and sample the result in sheet2
i'm using office 2007
many thanks for ur help.

regards,

reza

[GTO]

I tried filtering. Doesn't seem stellar fast, but appears reliable.

In a Standard Module:


Option Explicit

Sub exa()
Dim _
wksData As Worksheet, _
wksOutput As Worksheet, _
rngLRow As Range, _
rngData As Range, _
rngOutput As Range, _
aryProp As Variant, _
aryKabu As Variant, _
aryKeca As Variant, _
aryOutput_Horz As Variant, _
aryOutput_Vert As Variant, _
vPropVal As Variant, _
vKabuVal As Variant, _
x As Long, _
y As Long

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

'// 'Ready' a sideways array to hold vals //
ReDim aryOutput_Horz(1 To 4, 0 To 0)

'// Change sheetname to suit //
Set wksData = ThisWorkbook.Worksheets("Sheet1")

With wksData
'// Find last row (range), bail if nothing //
Set rngLRow = RangeFound(.Range("A2:D" & Rows.Count))
If rngLRow Is Nothing Then Exit Sub

'// If okay to here, skip header row and set a reference to data range //
Set rngData = Range(wksData.Range("A2"), .Cells(rngLRow.Row, "D"))

'// Reset autofiltering //
.AutoFilterMode = False
rngData.Offset(-1).Resize(rngData.Rows.Count + 1).AutoFilter

'// Build collections here and throughout of unique vals //
aryProp = RetCollection(rngData.Columns(1).Value)

For Each vPropVal In aryProp

'// Kill filter for ea val //
.AutoFilterMode = False

rngData.Offset(-1).Resize(rngData.Rows.Count + 1).AutoFilter _
Field:=1, Criteria1:=vPropVal

aryKabu = RetCollection(rngData.Columns(2).SpecialCells(xlCellTypeVisible).Value)

For Each vKabuVal In aryKabu

rngData.Offset(-1).Resize(rngData.Rows.Count + 1).AutoFilter _
Field:=2, Criteria1:=vKabuVal

aryKeca = RetCollection(rngData.Columns(3).SpecialCells(xlCellTypeVisible).Value)

'// Resize and add vals to 'sideways' array //
ReDim Preserve aryOutput_Horz(1 To 4, 1 To UBound(aryOutput_Horz, 2) + 1)

aryOutput_Horz(1, UBound(aryOutput_Horz, 2)) = vPropVal
aryOutput_Horz(2, UBound(aryOutput_Horz, 2)) = vKabuVal
aryOutput_Horz(3, UBound(aryOutput_Horz, 2)) = _
UBound(aryKeca, 1) - LBound(aryKeca, 1) + 1
aryOutput_Horz(4, UBound(aryOutput_Horz, 2)) = _
rngData.Columns(4).SpecialCells(xlCellTypeVisible).Count
Next
Next

'// Reset filter //
.AutoFilterMode = False
rngData.Offset(-1).Resize(rngData.Rows.Count + 1).AutoFilter
End With

'// Size 'vertical' array for plunking on sheet /
ReDim aryOutput_Vert(1 To UBound(aryOutput_Horz, 2), 1 To 4)

'// Transpose horizontal array to vertical //
For x = 1 To UBound(aryOutput_Horz, 2)
For y = 1 To 4
aryOutput_Vert(x, y) = aryOutput_Horz(y, x)
Next
Next

'// Add a sheet and size destination range //
Set wksOutput = ThisWorkbook.Worksheets.Add(Before:=wksData)
Set rngOutput = wksOutput.Range("A4").Resize(UBound(aryOutput_Vert, 1), 4)

'// Plunk in vals and pretty up dest sheet //
With rngOutput
.Value = aryOutput_Vert
With .Offset(-1).Resize(.Rows.Count + 1)
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
.BorderAround xlContinuous, xlThick, xlColorIndexAutomatic
End With
With .Offset(-1).Resize(1)
.Value = Array("Propinsi", "Kabupaten", "Kecamatan", "Desa")
.Interior.ColorIndex = 16
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
End With

.Columns("A:D").EntireColumn.AutoFit

With .Parent.Range("A1:D1")
.HorizontalAlignment = xlCenterAcrossSelection
With .Font
.Name = "Calibri"
.FontStyle = "Bold"
.Size = 11
End With
.Resize(, 1).Value = "Sample Result"
End With
End With

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Function RetCollection(aryVals) As Variant
Dim Val As Variant

With CreateObject("Scripting.Dictionary")
For Each Val In aryVals
.Item(Val) = Val
Next
RetCollection = .Items
End With
End Function

Function RangeFound(SearchRange As Range, _
Optional FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range

If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If

Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function

Hope that helps,

Mark

[reza_doang]

:omg: its really work...perfect mark....:bow:
u save my time...
:beerchug:
many many thanks for your help...

reza:joy: