So basically the code below is to help me automate a repetitive task.
However for some reason the only part not working as it should is the function where it changes K column from TRUE/FALSE to 1/0 accordingly...any ideas.. Thanks
Sub AutomateReporting()
Dim ws As Worksheet
Dim LastRowA As Long, LastRowK As Long, LastRowF As Long
Dim rng As Range, cell As Range
Dim destSheet As Worksheet
Dim sheetOrder() As String
Dim i As Long, j As Long
' Define the worksheet to work with
Set ws = ThisWorkbook.Sheets("sheet1") ' Change "sheet1" to your sheet's name
' Turn off screen updating to improve performance
Application.ScreenUpdating = False
' Clear any existing filters
ws.AutoFilterMode = False
' Find the last row with data in column A, K, and F
LastRowA = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
LastRowK = ws.Cells(ws.Rows.Count, 11).End(xlUp).Row
LastRowF = ws.Cells(ws.Rows.Count, 6).End(xlUp).Row
' Filter column A to find entries starting with 'AA'
ws.Range("A2:A" & LastRowA).AutoFilter Field:=1, Criteria1:="AA*", Operator:=xlFilterValues
' Store the range of visible rows with data excluding the header
On Error Resume Next ' In case no visible cells to delete
Set rng = ws.Range("A2:A" & LastRowA).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
' Delete visible rows containing 'AA' in column A
If Not rng Is Nothing Then
rng.EntireRow.Delete
End If
' Find the new last row with data in column A after deleting filtered rows
LastRowA = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
' Filter column K to find 'New'
ws.AutoFilterMode = False
ws.Range("K1:K" & LastRowK).AutoFilter Field:=1, Criteria1:="New"
' Find the last row with data in column K after filtering for 'New'
LastRowK = ws.Cells(ws.Rows.Count, 11).End(xlUp).Row
' Convert TRUE to 1 and FALSE to 0 in column K
For Each cell In ws.Range("K2:K" & LastRowK)
If cell.Value = "TRUE" Then
cell.Value = "1"
ElseIf cell.Value = "FALSE" Then
cell.Value = "0"
End If
Next cell
' Filter column F to find the unique values
Dim uniqueValues() As Variant
uniqueValues = GetUniqueValues(ws.Range("F2:F" & LastRowF))
' Define the order of sheets
ReDim sheetOrder(1 To 8) As String
sheetOrder(1) = "New"
sheetOrder(2) = "Acc"
sheetOrder(3) = "Canc"
sheetOrder(4) = "Surv"
sheetOrder(5) = "Unsch"
sheetOrder(6) = "Sche"
sheetOrder(7) = "En"
sheetOrder(8) = "Comp"
' Loop through each unique value in column F
For j = LBound(sheetOrder) To UBound(sheetOrder)
' Loop through unique values to find the matching one
For i = LBound(uniqueValues) To UBound(uniqueValues)
If StrComp(uniqueValues(i, 1), sheetOrder(j), vbTextCompare) = 0 Then
' Create a new sheet for the current unique value
Set destSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
' Set the sheet name
destSheet.Name = SanitizeSheetName(CStr(uniqueValues(i, 1)))
' Filter column F to find rows with the current unique value
ws.AutoFilterMode = False
ws.Range("F1:F" & LastRowF).AutoFilter Field:=1, Criteria1:=uniqueValues(i, 1)
' Copy visible rows to the new sheet
ws.Range("A1:K" & LastRowA).SpecialCells(xlCellTypeVisible).Copy destSheet.Range("A1")
' Clear filter
ws.AutoFilterMode = False
' Exit the loop once the sheet is created
Exit For
End If
Next i
Next j
' Turn on screen updating
Application.ScreenUpdating = True
MsgBox "MR.E", vbInformation
End Sub
Function GetUniqueValues(rng As Range) As Variant
Dim dict As Object
Dim cell As Range
Dim arr() As Variant
Dim i As Long
Set dict = CreateObject("Scripting.Dictionary")
For Each cell In rng
If Not dict.exists(cell.Value) Then
dict.Add cell.Value, Nothing
End If
Next cell
ReDim arr(1 To dict.Count, 1 To 1)
i = 1
For Each Key In dict.keys
arr(i, 1) = Key
i = i + 1
Next Key
GetUniqueValues = arr
End Function
Function SanitizeSheetName(sheetName As String) As String
Dim invalidChars As String
Dim i As Integer
Dim invalidChar As String
' Define invalid characters
invalidChars = ":/\?*[]"
' Replace invalid characters with underscores
For i = 1 To Len(invalidChars)
invalidChar = Mid(invalidChars, i, 1)
sheetName = Replace(sheetName, invalidChar, "_")
Next i
' Truncate to maximum allowed length
If Len(sheetName) > 31 Then
sheetName = Left(sheetName, 31)
End If
SanitizeSheetName = sheetName
End Function
Bookmarks