Re: VBA, Advanced Filter
I have noticed a slight flaw in the logic of the code, that may result in problems if there was to be no Node column in a worksheet. I have made some changes to correct that, and to fill down the sheet name, although these are untested:
Code
Sub AlwaysTestyv1()
Dim ws As Worksheet, wks As Worksheet, wksSummary As Worksheet
Dim y As Range, intRow As Long, i As Integer
Dim r As Range, lr As Long, myrg As Range
Dim boolWritten As Boolean, lngNextRow As Long
Dim intColNode As Integer, intColScenario As Integer
Dim intColNext As Integer, lngStartRow As Long
' Turn off screen updating and automatic calculation
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Create a new worksheet, if required
On Error Resume Next
Set wksSummary = ActiveWorkbook.Worksheets("Unique data")
On Error GoTo 0
If wksSummary Is Nothing Then
Set wksSummary = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
wksSummary.Name = "Unique data"
End If
' Set the initial output range, and assign column headers
With wksSummary
Set y = .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0)
Set r = y.Offset(0, 1)
lngStartRow = y.Row
.Range("A1:D1").Value = Array("File Name", "Sheet Name", "Node Name", "Scenario Name")
End With
' Check each sheet in turn
For Each ws In ActiveWorkbook.Worksheets
With ws
' Only action the sheet if it's not the 'Unique data' sheet
If .Name <> wksSummary.Name Then
boolWritten = False
' Find the Scenario column
intColScenario = 0
On Error Resume Next
intColScenario = WorksheetFunction.Match("scenarioName", .Rows(1), 0)
On Error GoTo 0
If intColScenario > 0 Then
' Only action if there is data in column E
If Application.WorksheetFunction.CountA(.Columns(intColScenario)) > 1 Then
' Find the next free column, in which the extract formula will be placed
intColNext = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
' Assign formulas to the next free column to identify the scenario name to the left of the first _ character
.Cells(1, intColNext).Value = "Test"
lr = .Cells(.Rows.Count, intColScenario).End(xlUp).Row
Set myrg = .Range(.Cells(2, intColNext), .Cells(lr, intColNext))
With myrg
.ClearContents
.FormulaR1C1 = "=IFERROR(LEFT(RC" & intColScenario & ",FIND(INDEX({""+"",""-"",""_"",""$"",""%""},1,MATCH(1,--(ISNUMBER(FIND({""+"",""-"",""_"",""$"",""%""},RC" & _
intColScenario & "))),0)), RC" & intColScenario & ")-1), RC" & intColScenario & ")"
.Value = .Value
End With
' Copy unique values from the formula column to the 'Unique data' sheet, and write sheet & file details
.Range(.Cells(1, intColNext), .Cells(lr, intColNext)).AdvancedFilter xlFilterCopy, , r, True
r.Offset(0, -3).Value = ws.Name
r.Offset(0, -2).Value = ws.Parent.Name
' Clear the interim results
.Range(.Cells(1, intColNext), .Cells(lr, intColNext)).ClearContents
' Delete the column header copied to the list
r.Delete Shift:=xlUp
boolWritten = True
End If
End If
' Find the Node column
intColNode = 0
On Error Resume Next
intColNode = WorksheetFunction.Match("node", .Rows(1), 0)
On Error GoTo 0
If intColNode > 0 Then
' Only action if there is data in column A
If Application.WorksheetFunction.CountA(.Columns(intColNode)) > 1 Then
lr = .Cells(.Rows.Count, intColNode).End(xlUp).Row
' Copy unique values from column A to the 'Unique data' sheet, and write sheet & file details (if not already written)
.Range(.Cells(1, intColNode), .Cells(lr, intColNode)).AdvancedFilter xlFilterCopy, , y, True
If Not boolWritten Then
y.Offset(0, -2).Value = ws.Name
y.Offset(0, -1).Value = ws.Parent.Name
End If
' Delete the column header copied to the list
y.Delete Shift:=xlUp
End If
End If
' Identify the next row, based on the most rows used in columns C & D
lngNextRow = WorksheetFunction.Max(wksSummary.Cells(wksSummary.Rows.Count, 3).End(xlUp).Row, wksSummary.Cells(wksSummary.Rows.Count, 4).End(xlUp).Row) + 1
.Range(.Cells(lngStartRow, 2), .Cells(lngNextRow - 1, 2)).FillDown
Set y = wksSummary.Cells(lngNextRow, 3)
Set r = y.Offset(0, 1)
lngStartRow = y.Row
End If
End With
Next ws
' Autofit column widths of the report
wksSummary.Range("A1:D1").EntireColumn.AutoFit
' Reset system settings
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Display More