Code: Select all
Sub VBAArrayTypeAlternativeToFilter()
' Worksheets
Dim wS As Worksheet
Dim wM As Worksheet
Dim wA As Worksheet
' Range Info
Dim m As Long
Dim arrK As Variant
' Indices needed for output arrays
Dim strMain As String, strAnother As String
Dim cnt As Long
Dim clms As Variant
Dim strRws() As String
Dim Rws() As String
Dim arrOut As Variant
Dim i As Long
Dim r As Long
Dim n As Long
Dim c As Range
Dim a As String
Set wS = Worksheets("Source")
Set wM = Worksheets("Main Store")
Set wA = Worksheets("Another Stores")
m = wS.Range("A" & Rows.Count & "").End(xlUp).Row
arrK = wS.Range("K1:L" & m).Value
strMain = "7"
strAnother = "7"
For cnt = 8 To m
If arrK(cnt, 2) Like "*payment was made" Then
If arrK(cnt, 1) = "main store" Then
strMain = strMain & " " & cnt
Else
strAnother = strAnother & " " & cnt
End If
End If
Next cnt
'Output Main Store
clms = Array(1, 4, 6, 13, 14)
strRws = Split(strMain)
ReDim Rws(1 To UBound(strRws) + 1, 1 To 1)
For cnt = 1 To UBound(strRws) + 1
Rws(cnt, 1) = strRws(cnt - 1)
Next cnt
arrOut = Application.Index(wS.Cells, Rws, clms)
wM.Activate
wM.Range("19:" & wM.Rows.Count).Clear
wM.Range("19:" & wM.Rows.Count).Delete
m = UBound(arrOut, 1)
With wM.Range("A18").Resize(UBound(arrOut, 1), UBound(arrOut, 2))
.Value = arrOut
.Sort Key1:=wM.Range("C18"), Header:=True
End With
For i = Application.Ceiling(m / 27, 1) To 1 Step -1
r = 19 + 27 * i
wM.Range("A" & r).EntireRow.Insert
wM.Range("B" & r).Value = "Deputy Director"
wM.Range("D" & r).Value = "General Director"
wM.HPageBreaks.Add wM.Range("A" & r + 1)
Next i
n = wM.Range("B" & wM.Rows.Count).End(xlUp).Row
With wM.Range("A18:E" & n)
.Font.Name = "Times New Roman"
.Font.Size = 13
.RowHeight = 17
.Borders.LineStyle = xlContinuous
End With
With wM.Range("B18:B" & n)
Set c = .Find(What:="Deputy Director", LookAt:=xlWhole)
If Not c Is Nothing Then
a = c.Address
Do
With c.Offset(0, -1).Resize(1, 5)
.Borders(xlEdgeLeft).LineStyle = xlLineStyleNone
.Borders(xlInsideVertical).LineStyle = xlLineStyleNone
.Borders(xlEdgeRight).LineStyle = xlLineStyleNone
.Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
End With
Set c = .FindNext(After:=c)
Loop Until c.Address = a
End If
End With
'Output Another Stores
clms = Array(1, 4, 6, 13, 14)
strRws = Split(strAnother)
ReDim Rws(1 To UBound(strRws, 1) + 1, 1 To 1)
For cnt = 1 To UBound(strRws, 1) + 1
Rws(cnt, 1) = strRws(cnt - 1)
Next cnt
arrOut = Application.Index(wS.Cells, Rws, clms)
wA.Activate
wA.Range("19:" & wM.Rows.Count).Clear
wA.Range("19:" & wM.Rows.Count).Delete
m = UBound(arrOut, 1)
With wA.Range("A18").Resize(m, UBound(arrOut, 2))
.Value = arrOut
.Sort Key1:=wA.Range("C18"), Header:=True
End With
For i = Application.Ceiling(m / 27, 1) To 1 Step -1
r = 19 + 27 * i
wA.Range("A" & r).EntireRow.Insert
wA.Range("B" & r).Value = "Deputy Director"
wA.Range("D" & r).Value = "General Director"
wA.HPageBreaks.Add wA.Range("A" & r + 1)
Next i
n = wA.Range("B" & wA.Rows.Count).End(xlUp).Row
With wA.Range("A18:E" & n)
.Font.Name = "Times New Roman"
.Font.Size = 13
.RowHeight = 17
.Borders.LineStyle = xlContinuous
End With
With wA.Range("B18:B" & n)
Set c = .Find(What:="Deputy Director", LookAt:=xlWhole)
If Not c Is Nothing Then
a = c.Address
Do
With c.Offset(0, -1).Resize(1, 5)
.Borders(xlEdgeLeft).LineStyle = xlLineStyleNone
.Borders(xlInsideVertical).LineStyle = xlLineStyleNone
.Borders(xlEdgeRight).LineStyle = xlLineStyleNone
.Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
End With
Set c = .FindNext(After:=c)
Loop Until c.Address = a
End If
End With
End Sub