Excel VBA Multiple Sheets

The below Excel VBA codes is to filter for all various cost centres and allocate each cost centre to employer groups. This creates multiple sheets – one sheet for each employer!

Option Explicit

Sub allocate()
Dim lLRow As Long

' Change File Date to read current date.
Worksheets("Sheet1").Select
Range("B2").Select
Range(Selection, Selection.End(xlDown)).Formula = "=TODAY()"

' Get the correct worksheet to run the macro on.
With Worksheets("Sheet1") 'or ThisWorkbook.Worksheets("Sheet1")

' lLRow = .Range("A" & Rows.count).End(xlUp).Row (use this for entire row but takes a lot of memory)
lLRow = .Range("A1000").End(xlUp).Row

' This will check if there are any data to filter, if no, macro will exit.
If Not lLRow > 1 Then Exit Sub
If .AutoFilterMode Then .Cells.AutoFilter

' Filtering all cost centres that are part of Prime Group Services
.Columns("A:A").AutoFilter Field:=1, Criteria1:=Array( _
"1PPBN000P", "1BPGG020S", "1DROU000P", "1JAMA000S", "1KPTY020S", _
"1PARK000P", "1PPBN000P", "1PPMO000P", "1PPWA000P", _
"AADWA000P", "ADWAF000S", "1PRIME00S", "1BJAM020S", "1BPGG010S", "1PPBE000P", _
"1GPMM000S", "1SHAN000P", "1IMAG000S"), Operator:=xlFilterValues

' Copy the filtered data and paste them in a new worksheet.
.Range("A2:A" & lLRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
ThisWorkbook.Worksheets("PGS").Cells(2, 1)

' Remove the filter. //
.Cells.AutoFilter
End With

' Change the Employer ID name to match QuickSuper Setup
Worksheets("PGS").Select

' replace "QS11390PRIME" with "QS11390PRIME"
Cells.Replace What:="QS11390PRIME", Replacement:="QS11390PRIME", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

' Copy the EmployerID as File Reference so that there is only a unique reference
Range("AM2:AM2000").Value = Range("A2:A2000").Value
Range("A2:A2000").Value = Range("E2:E2000").Value
Range("A1:AM1").Value = Worksheets("Sheet1").Range("A1:AM1").Value

'/////////////////////////////////////////////////////////////////////

' Get the correct worksheet to run the macro on.
With Worksheets("Sheet1") 'or ThisWorkbook.Worksheets("Sheet1")

' lLRow = .Range("A" & Rows.count).End(xlUp).Row (use this for entire row but takes a lot of memory)
lLRow = .Range("A1000").End(xlUp).Row

' This will check if there are any data to filter, if no, macro will exit.
If Not lLRow > 1 Then Exit Sub
If .AutoFilterMode Then .Cells.AutoFilter

' Filtering all cost centres that are part of Prime Group Services
.Columns("A:A").AutoFilter Field:=1, Criteria1:=Array( _
"1MCSS000S", "1PPMC000P", "1PRIM000S", "1PPBO000P", "1K4SS000S", "1LAKE000P", _
"1PRIMC00S", "1PPBAOOOP", "1PRIMBOOS", "1CSPR000S", "1LAUR000P", _
"1LAUR000S", "1CSPR000P", "1ENDAOOOP", "1ENDAOOOS", "1MOEPH00P", _
"1GLENR00P", "1GLENR00S", "1BACDC00P", "1BACDC00S", "1PPSS010S", "1PRCDCOOP", _
"1ALBE000S", "1ALBE000P", "1CHUR000P", "1MOEPH00S", "1ENDEAOOS", "1PRCDCOOS", _
"1OFCDC00S", "1OFCDC00P", "1ENDEAOOP"), Operator:=xlFilterValues

' Copy the filtered data and paste them in a new worksheet.
.Range("A2:A" & lLRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
ThisWorkbook.Worksheets("PGS2").Cells(2, 1)

' Remove the filter. //
.Cells.AutoFilter
End With

' Change the Employer ID name to match QuickSuper Setup
Worksheets("PGS2").Select

' replace "QS11390PRIME" with "QS11390PRIME"
Cells.Replace What:="QS11390PRIME", Replacement:="QS11390PRIME", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

' Copy the EmployerID as File Reference so that there is only a unique reference
Range("AM2:AM2000").Value = Range("A2:A2000").Value
Range("A2:A2000").Value = Range("E2:E2000").Value
Range("A1:AM1").Value = Worksheets("Sheet1").Range("A1:AM1").Value

'/////////////////////////////////////////////////////////////////////

' Get the correct worksheet to run the macro on.
With Worksheets("Sheet1") 'or ThisWorkbook.Worksheets("Sheet1")

' lLRow = .Range("A" & Rows.count).End(xlUp).Row (use this for entire row but takes a lot of memory)
lLRow = .Range("A1000").End(xlUp).Row

' This will check if there are any data to filter, if no, macro will exit.
If Not lLRow > 1 Then Exit Sub
If .AutoFilterMode Then .Cells.AutoFilter

' Filtering all cost centres that are part of Advantage Pharmacy.
.Columns("A:A").AutoFilter Field:=1, Criteria1:="1ADVAN00S"

' Copy the filtered data and paste them in a new worksheet.
.Range("A2:A" & lLRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
ThisWorkbook.Worksheets("Advantage").Cells(2, 1)

' Remove the filter. //
.Cells.AutoFilter
End With

' Change the Employer ID name to match QuickSuper Setup
Worksheets("Advantage").Select

' replace "QS11390PRIME" with "QS11390PRIME"
Cells.Replace What:="QS11390PRIME", Replacement:="QS11390ADVANTAGE", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

' Copy the EmployerID as File Reference so that there is only a unique reference.
Range("AM2:AM2000").Value = Range("A2:A2000").Value
Range("A2:A2000").Value = Range("E2:E2000").Value
Range("A1:AM1").Value = Worksheets("Sheet1").Range("A1:AM1").Value

Worksheets("Instructions").Select

End Sub

This macro is to clear out all contents of relevant spreadsheets before the allocation is done.

Sub Delete()
'
' Macro3 Macro
'

'
Dim ws As Worksheet

For Each ws In Sheets(Array("PGS", "Advantage", "PGS2", "Seymour", "SAS", "Windsor", "KKM", "Thompson", "Holdings"))
ws.Cells.ClearContents

Next ws

Worksheets("Instructions").Select

End Sub

Sub Delete_DataSheet()

Worksheets("Sheet1").Select
Cells.Select
Selection.ClearContents

Worksheets("Instructions").Select

End Sub

This is to consolidate all data in multiple worksheets onto a single worksheet and refreshing a pivot table that looks at that single worksheet.

Sub Copy()
Dim ws As Worksheet, _
LR1 As Long, _
LR2 As Long
Worksheets("Consol").Select
Cells.Select
Selection.ClearContents

Application.ScreenUpdating = False
For Each ws In Sheets(Array("PGS", "Advantage", "PGS2", "Seymour", "SAS", "Windsor", "KKM", "Thompson", "Holdings"))
'For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Consol" Then
LR1 = Sheets("Consol").Range("A" & Rows.count).End(xlUp).Row + 1
LR2 = ws.Range("A" & Rows.count).End(xlUp).Row
ws.Range("A2:AM" & LR2).Copy Destination:=Sheets("Consol").Range("A" & LR1)
End If
Next ws
Application.ScreenUpdating = True

Range("A1:AM1").Value = Worksheets("Sheet1").Range("A1:AM1").Value

Sheets("PivotSummary").PivotTables("ConsolPivot").PivotCache.Refresh

Worksheets("PivotSummary").Select

End Sub

Conditional Formatting Techniques


Sub CF_VBA()
Dim rnArea As Range, rnCell As Range
Dim ic As Long

Set rnArea = Range("A1:Q50")

For Each rnCell In rnArea
With rnCell
If .Value <> 0 Then
Select Case True
Case rnCell Like "*SWJ*"
.Interior.ColorIndex = 35
Case rnCell Like "*CC*"
.Interior.ColorIndex = 35
Case rnCell Like "*KSM*"
.Interior.ColorIndex = 35
Case rnCell Like "*HG*"
.Interior.ColorIndex = 35
Case rnCell Like "*EO*"
.Interior.ColorIndex = 35
Case rnCell Like "*KL*"
.Interior.ColorIndex = 35
Case rnCell Like "*PJ*"
.Interior.ColorIndex = 35
Case rnCell Like "*ADF*"
.Interior.ColorIndex = 35
End Select
Else
ic = xlNone
End If
'.Interior.ColorIndex = ic
End With
Next rnCell
End Sub

Leave a Reply


*