Dim wsTarget As Worksheet, LR As Long
Sub Test()
Dim aStartTime
'Speeding Up VBA Code
With Application
.ScreenUpdating = False 'Prevent screen flickering
'.Calculation = xlCalculationManual 'Preventing calculation
.DisplayAlerts = False 'Turn OFF alerts
.EnableEvents = False 'Prevent All Events
End With
'Start Timer
aStartTime = Now()
'Set Variables
Set wsTarget = Sheets("Sheet1") '<<== Change as Required
'Get Last Row in Destination sheet
LR = wsTarget.Cells(Rows.Count, "A").End(xlUp).Row
'Run Vba now
Call Mix1
Call Mix2
Call Mix3
'Remove fixed address
wsTarget.Columns("F:F").Replace What:="$", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Fill in blanks in Col E
On Error Resume Next
With wsTarget.Range("E5:E" & LR).SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[-1]C"
End With
On Error GoTo 0
'Clears Clipboard
Application.CutCopyMode = False
'Paste Special as Values
With wsTarget.Range("E5:E" & LR)
.Value = .Value
End With
'Fill in blanks with cell addresses
Dim rCells As Range, Rng As Range
Set Rng = wsTarget.Range("F7:F" & LR)
For Each rCells In Rng
rCells.Formula = "A" & rCells.Row
Next rCells
'------------------------------------
'Copy Formulas
Dim fArray As Variant, eArray As Variant
Dim r As Long, z As Long
eArray = wsTarget.Range("E8:E" & LR).Value
fArray = wsTarget.Range("F8:F" & LR).Value
r = 8
For z = 1 To UBound(eArray)
On Error Resume Next
wsTarget.Range("G" & r).Formula = "=" & fArray(z, 1) & "&" & eArray(z, 1)
On Error GoTo 0
r = r + 1
Next z
'-------------------------------
'Tidy up by deleting unnecessary formulas
Dim FilterRng As Range, FilterRngClear As Range
Set FilterRng = wsTarget.Range("$A$7:$G$" & LR)
Set FilterRngClear = FilterRng.Offset(1, 4).Resize(FilterRng.Rows.Count - 1, 3)
'Removes AutoFilter if one exists
wsTarget.AutoFilterMode = False
With FilterRng
.AutoFilter Field:=1, Criteria1:="Account Code"
FilterRngClear.SpecialCells(xlCellTypeVisible).ClearContents 'Clears Range("E8:G50").visible cells only
.AutoFilter Field:=1, Criteria1:="Account Code"
FilterRngClear.SpecialCells(xlCellTypeVisible).ClearContents 'Clears Range("E8:G50")
.AutoFilter Field:=1, Criteria1:="Total"
FilterRngClear.SpecialCells(xlCellTypeVisible).ClearContents 'Clears Range("E8:G50")
.AutoFilter Field:=1, Criteria1:="="
FilterRngClear.SpecialCells(xlCellTypeVisible).ClearContents 'Clears Range("E8:G50")
.AutoFilter Field:=1, Criteria1:="*Cost*"
FilterRngClear.SpecialCells(xlCellTypeVisible).ClearContents 'Clears Range("E8:G50")
End With
'Removes AutoFilter if one exists
wsTarget.AutoFilterMode = False
With wsTarget
.Columns("F:F").Delete Shift:=xlToLeft
.Columns("E:E").ClearContents
.Columns("F:F").EntireColumn.AutoFit
End With
'Release memory
Set wsTarget = Nothing
Set Rng = Nothing
Set FilterRng = Nothing
Set FilterRngClear = Nothing
'Speeding Up VBA Code
With Application
.ScreenUpdating = True 'Prevent screen flickering
'.Calculation = xlAutomatic 'Preventing calculation
.DisplayAlerts = True 'Turn OFF alerts
.EnableEvents = True 'Prevent All Events
End With
'End Timer
MsgBox "Time taken: " & Format(Now() - aStartTime, "h:mm:ss"), vbInformation, "Job Done"
End Sub
Sub Mix1()
' For All Matching Values in Second Column
' Add 'X' to Column D
Dim arTemp() As String 'Temp Array
Dim bFound As Boolean 'Flag
Dim i1 As Integer 'Array Counter
Dim List As Variant
Dim arList() As String 'Temp Array
Dim i2 As Integer 'Array Counter
Dim j As Integer
bFound = FindAll("Cost Center", wsTarget, "A1:A" & LR, arTemp())
If bFound = True Then
For i1 = 1 To UBound(arTemp)
' The Row Number Can be used for extracting data
ActiveSheet.Range(arTemp(i1)).Offset(0, 4).Value = arTemp(i1)
Next i1
Else
MsgBox "Search Text Not Found"
End If
End Sub
Sub Mix2()
' For All Matching Values in Second Column
' Add 'X' to Column D
Dim arTemp() As String 'Temp Array
Dim bFound As Boolean 'Flag
Dim i1 As Integer 'Array Counter
Dim List As Variant
Dim arList() As String 'Temp Array
Dim i2 As Integer 'Array Counter
Dim j As Integer
bFound = FindAll("Account Code", wsTarget, "A1:A" & LR, arTemp())
If bFound = True Then
For i1 = 1 To UBound(arTemp)
' The Row Number Can be used for extracting data
ActiveSheet.Range(arTemp(i1)).Offset(1, 5).Value = arTemp(i1)
Next i1
Else
MsgBox "Search Text Not Found"
End If
End Sub
Sub Mix3()
' For All Matching Values in Second Column
' Add 'X' to Column D
Dim arTemp() As String 'Temp Array
Dim bFound As Boolean 'Flag
Dim i1 As Integer 'Array Counter
Dim List As Variant
Dim arList() As String 'Temp Array
Dim i2 As Integer 'Array Counter
Dim j As Integer
bFound = FindAll("Total", wsTarget, "A1:A" & LR, arTemp())
If bFound = True Then
For i1 = 1 To UBound(arTemp)
' The Row Number Can be used for extracting data
ActiveSheet.Range(arTemp(i1)).Offset(-1, 5).Value = arTemp(i1)
Next i1
Else
MsgBox "Search Text Not Found"
End If
End Sub
Function FindAll(ByVal sText As String, ByRef oSht As Worksheet, ByRef sRange As String, ByRef arMatches() As String) As Boolean
' --------------------------------------------------------------------------------------------------------------
' FindAll - To find all instances of the1 given string and return the row numbers.
' If there are not any matches the function will return false
' --------------------------------------------------------------------------------------------------------------
On Error GoTo Err_Trap
Dim rFnd As Range ' Range Object
Dim iArr As Integer ' Counter for Array
Dim rFirstAddress ' Address of the First Find
' -----------------
' Clear the Array
' -----------------
Erase arMatches
Set rFnd = oSht.Range(sRange).Find(What:=sText, LookIn:=xlValues, LookAt:=xlPart)
If Not rFnd Is Nothing Then
rFirstAddress = rFnd.Address
Do Until rFnd Is Nothing
iArr = iArr + 1
ReDim Preserve arMatches(iArr)
arMatches(iArr) = rFnd.Address ' rFnd.Row ' Store the Row where the text is found
Set rFnd = oSht.Range(sRange).FindNext(rFnd)
If rFnd.Address = rFirstAddress Then Exit Do ' Do not allow wrapped search
Loop
FindAll = True
Else
' ----------------------
' No Value is Found
' ----------------------
FindAll = False
End If
' -----------------------
' Error Handling
' -----------------------
Err_Trap:
If Err <> 0 Then
MsgBox Err.Number & " " & Err.Description, vbInformation, "Find All"
Err.Clear
FindAll = False
Exit Function
End If
End Function
> </o
