@CDP1802:
Update 2 - The code with modifications I made as the filter was failing at the first sheet itself.
Instead of selecting 1 column, I selected the full range and used the colno variable to do the filtering.
This worked for fully but took a huge amount of time (nearly 10 minutes) to paste 8200 rows of data with 90 cols for the 1st sheet (overall took 1 hour). I also added Paste:=xlPasteValues argument to be doubly sure but it is still taking a long time. It goes through at a better speed for the sheets having lower amount of data.
Any idea why this could be happening?
Also, can you change the filter logic in your code? I will mark that as the accepted answer.
Sub test()
Const FIRST_SHEET = 100
Const LAST_SHEET = 118
Const TARGET_ROWNO = 1 '
Const TARGET_COLNO = 7 ' G
Const FILTER_COL = "Vertical"
Dim OFLastCol As Long
Dim OFLastRow As Long
Dim wbData As Workbook, wbMaster As Workbook
Dim ws As Worksheet, wsData As Worksheet, wsMaster As Worksheet
Dim sFolder As String, sFile As String, sOption As String
Dim rng As Variant, colno As Integer, iLastRow As Long, iLastCol As Integer
Dim crit As Variant, n As Long
Dim dict As Object, sCodeName As String
Set dict = CreateObject("Scripting.Dictionary")
sOption = Sheet52.Range("H8").Value 'capturing selected vertical
Select Case UCase(sOption) 'setting the filter values
Case "INSURANCE": crit = Array("INSURANCE")
Case "BFS": crit = Array("BFS")
Case "PNR": crit = Array("RETAIL", "MLEU", "T&H")
Case "FSI GGM": crit = Array("INSURANCE", "BFS")
Case Else
MsgBox "No option selected", vbCritical
Exit Sub
End Select
' select folder
Application.StatusBar = "Please be select folder to scan..."
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.InitialFileName = sFolder
.Show
sFolder = .SelectedItems(1)
End With
sFile = Dir(sFolder & "\*.xls*")
Set wbMaster = ThisWorkbook
' clear data sheets
' and map code names to index
For Each ws In wbMaster.Sheets
sCodeName = ws.CodeName 'Sheet100 to sheet118
dict(sCodeName) = ws.Index ' codename to index
' clear old data
n = Mid(sCodeName, 6)
If n >= FIRST_SHEET And n <= LAST_SHEET Then
Set rng = ws.UsedRange
iLastCol = rng.Column + rng.Columns.Count - 1
iLastRow = rng.Row + rng.Rows.Count - 1
If iLastCol >= TARGET_COLNO Then
Set rng = ws.Range(ws.Cells(TARGET_ROWNO, TARGET_COLNO), ws.Cells(iLastRow, iLastCol))
rng.Cells.ClearContents
End If
End If
Next
MsgBox ("data cleared")
' scan files
n = 100
Do While Len(sFile) > 0
Set wbData = Workbooks.Open(sFolder & "\" & sFile, ReadOnly:=True) ' updatelink, readonly
' open each sheet in turn
For Each wsData In wbData.Sheets
' find the filter column in row 1
Set rng = wsData.Rows(1).Find(FILTER_COL, LookAt:=xlWhole)
If Not rng Is Nothing Then
colno = rng.Column
iLastRow = wsData.Cells(Rows.Count, colno).End(xlUp).Row
If iLastRow > 1 Then
' range to copy and apply filter to one column
Set rng = rng.Resize(iLastRow, 1)
'rng.AutoFilter Field:=1, Criteria1:=crit, Operator:=xlFilterValues
OFLastCol = wsData.Range("A1").End(xlToRight).Column
OFLastRow = wsData.Cells(wsData.Rows.Count, OFLastCol).End(xlUp).Row
Set rng = wsData.Range("A1", wsData.Cells(OFLastRow, OFLastCol))
rng.AutoFilter Field:=colno, Criteria1:=crit, Operator:=xlFilterValues
Set rng = rng.SpecialCells(xlCellTypeVisible)
' is there data to copy
If rng.Rows.Count > 1 Or rng.Areas.Count > 1 Then
' check sheet available
sCodeName = "Sheet" & n
If dict.exists(sCodeName) Then
Set wsMaster = wbMaster.Sheets(dict(sCodeName))
Else
MsgBox sCodeName & " not found", vbCritical
Exit Sub
End If
' copy / paste all columns of visible rows
wsData.UsedRange.SpecialCells(xlCellTypeVisible).Copy
With wsMaster.Cells(TARGET_ROWNO, TARGET_COLNO)
.PasteSpecial Paste:=xlPasteValues
End With
'wsMaster.Range("G1").Select
'Selection.PasteSpecial Paste:=xlPasteValues, _
'Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
wsMaster.Activate
wsMaster.Range("A1").Select
Else
MsgBox "No data after filter on sheet " & wsData.Name, vbExclamation, wbData.Name
End If
Else
MsgBox "No data in column " & colno & " on sheet " & wsData.Name, vbExclamation, wbData.Name
End If
Else
MsgBox FILTER_COL & " not found on sheet " & wsData.Name, vbExclamation, wbData.Name
End If
n = n + 1 ' next data sheet
Next
wbData.Close False
sFile = Dir() ' next file in folder
Loop
MsgBox sFolder & " files scanned for option " & sOption, vbInformation
End Sub
