Hi all I have a workbook that comes out daily with stats about work related issues, with a number of different tabs , and I need to extract the data from one worksheet that contains 10000-30000 rows of data but I only want data based on a list of names that relate to my tream. the names can be found in that particular worksheet in a particular column. I have managed to source the vba below but it does not paste any data to the new workbook . I dont know if it is the actual filter part that is not working.
Can any one provide some help or if they know of a vba that does so. many thanks!
VBA Code:
Sub FilterAndCopyData()
Dim fso As Object
Dim fldr As Object
Dim sFldr As String
Dim wbk As Workbook
Dim wks As Worksheet
Dim rng As Range
Dim names As Variant
Dim name As Variant
Dim newWbk As Workbook
Dim newWks As Worksheet
' List of names to filter
names = Array("Name1", "Name2", "Name3") ' Add more names as needed
' Create new workbook for filtered data
Set newWbk = Workbooks.Add
Set newWks = newWbk.Sheets(1)
' Path to the folder
sFldr = "C:\Path\To\Folder"
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldr = fso.GetFolder(sFldr)
' Call the recursive procedure
ProcessFolder fldr, names, newWks
' Save the new workbook with filtered data
newWbk.SaveAs "C:\Path\To\NewWorkbook.xlsx"
End Sub
Sub ProcessFolder(fldr As Object, names As Variant, newWks As Worksheet)
Dim subFldr As Object
Dim file As Object
Dim wbk As Workbook
Dim wks As Worksheet
Dim rng As Range
Dim name As Variant
For Each subFldr In fldr.SubFolders
ProcessFolder subFldr, names, newWks ' Recursive call for subfolders
Next subFldr
For Each file In fldr.Files
If Right(file.Name, 4) = "xlsx" Or Right(file.Name, 3) = "xls" Then ' Check if file is an Excel workbook
Set wbk = Workbooks.Open(file.Path)
On Error Resume Next ' Ignore error if worksheet not found
Set wks = wbk.Sheets("activity")
On Error GoTo 0 ' Reset error handling
If Not wks Is Nothing Then ' Check if worksheet was found
For Each name In names
Set rng = wks.Range("G1:G" & wks.Cells(wks.Rows.Count, "G").End(xlUp).Row) ' Adjust range as needed
' Filter data based on name and copy to new worksheet
rng.AutoFilter Field:=1, Criteria1:="=*" & name & "*", Operator:=xlAnd
rng.SpecialCells(xlCellTypeVisible).Copy Destination:=newWks.Cells(newWks.Cells(newWks.Rows.Count, "A").End(xlUp).Row + 1, "A")
rng.AutoFilter ' Remove filter
' Clear objects for next iteration
Set rng = Nothing
Next name
Set wks = Nothing ' Clear objects for next iteration
End If
wbk.Close SaveChanges:=False ' Close workbook without saving changes
Set wbk = Nothing ' Clear objects for next iteration
End If
Next file
End Sub
