This code has been created To transfer Specific columns from the CustomersData sheet to two sheets ( monetary & Delayed ) based on in columns T & S
Code: Select all
Sub test()
Dim LR As Long, x As Long, i As Long, j As Long, z As Long, xx As Long, K As Long, L As Long
Application.ScreenUpdating = 0
With Sheets("CustomersData")
LR = .Range("A" & Rows.Count).End(xlUp).Row
ReDim Arr(1 To LR, 1 To 64)
ReDim MM(1 To LR, 1 To 17)
ReDim DD(1 To LR, 1 To 7)
Arr = .Range("A8", "BL" & LR).Value
Dim WS As Worksheet
Set WS = Sheets.Add(After:=Sheets(Worksheets.Count))
WS.Range("A8", "BL" & LR) = Arr
WS.Sort.SortFields.Clear
WS.Sort.SortFields.Add Key:=Range("D8", "D" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
WS.Sort.SortFields.Add Key:=Range("C8", "C" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With WS.Sort
.SetRange Range("A8", "BL" & LR)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Arr = WS.Range("A8", "BL" & LR).Value
Application.DisplayAlerts = False
WS.Delete
Application.DisplayAlerts = True
i = 1: j = 1: K = 1: L = 1
For x = 1 To UBound(Arr)
If Arr(x, 19) = "Cash payment" Then
MM(i, 1) = K: MM(i, 2) = "'" & Arr(x, 2): MM(i, 3) = Arr(x, 3): MM(i, 4) = Arr(x, 4)
MM(i, 5) = Arr(x, 11): MM(i, 6) = Arr(x, 35): MM(i, 7) = Arr(x, 36): MM(i, 8) = Arr(x, 13): MM(i, 9) = Arr(x, 14): MM(i, 10) = Arr(x, 15): MM(i, 11) = Arr(x, 16): MM(i, 12) = Arr(x, 17): MM(i, 13) = Arr(x, 18): MM(i, 14) = Arr(x, 43): MM(i, 15) = Arr(x, 44): MM(i, 16) = Arr(x, 61): MM(i, 17) = Arr(x, 62)
z = z + 1
K = K + 1
If z = 25 Then
z = 0: i = i + 5
Else
i = i + 1
End If
End If
If Arr(x, 20) = "Deferred payment" Then
DD(j, 1) = L: DD(j, 2) = "'" & Arr(x, 2): DD(j, 3) = Arr(x, 3): DD(j, 4) = Arr(x, 4)
DD(j, 5) = Arr(x, 43): DD(j, 6) = Arr(x, 44): DD(j, 7) = Arr(x, 24)
xx = xx + 1
L = L + 1
If xx = 30 Then
xx = 0: j = j + 5
Else
j = j + 1
End If
End If
Next
With Sheets("monetary")
LR = .Range("A" & Rows.Count).End(xlUp).Row
If LR > 6 Then .Range("A8", "Q" & LR).ClearContents
.Range("A8").Resize(UBound(Arr), 17) = MM
For i = 1 To Application.RoundUp((Application.Match(9 ^ 9, .Range("A:A"), 1) - 7) / 29, 0)
.HPageBreaks.Add Before:=Cells(29 * i + 8, 1)
.Cells(29 * i + 4, 1) = "Storekeeper" & String(50, " ") & "Storekeeper2" & String(50, " ") & "Storekeeper3" & String(50, " ") & "Storekeeper4"
.Range("A" & 29 * i + 4, "Q" & 29 * i + 4).HorizontalAlignment = xlCenterAcrossSelection
' inserting tables borders for each row 25
' How can I customize preferences such as font type, font size, row height, and so on
' .Range("A" & 29 * i + 4, "Q" & 29 * i + 4).HorizontalAlignment = xlCenterAcrossSelection
' .PageSetup.PrintArea =
.PageSetup.PrintTitleRows = "$1:$7"
Next
End With
With Sheets("Delayed")
LR = .Range("A" & Rows.Count).End(xlUp).Row
If LR > 6 Then .Range("A8", "Q" & LR).ClearContents
.Range("A8").Resize(UBound(Arr), 7) = DD
For i = 1 To Application.RoundUp((Application.Match(9 ^ 9, .Range("A:A"), 1) - 7) / 34, 0)
.HPageBreaks.Add Before:=Cells(34 * i + 8, 1)
.Cells(34 * i + 4, 1) = "Storekeeper" & String(70, " ") & "Storekeeper1" & String(70, " ") & "Storekeeper2"
.Range("A" & 34 * i + 4, "G" & 34 * i + 4).HorizontalAlignment = xlCenterAcrossSelection
' inserting tables borders for each row 30
' .Range("A" & 34 * i + 4, "G" & 34 * i + 4).HorizontalAlignment = xlCenterAcrossSelection
' .PageSetup.PrintArea =
.PageSetup.PrintTitleRows = "$1:$7"
Next
End With
End With
End Sub
and also Customize some preferences for font type, font size, rows height, and columns width.
Attached sample may clarify more ... Really appreciate you guys help.
Thank you very much for all of you