VBA Trying to search for string, use range to copy the information in that column's values and output it to a spreadsheet - vba

Question

I have many Excel documents (containing about a page of information, A-H columns and 1-25rows give or take a few) in a folder titled "Progress".
In one Excel document, I am trying to search for a particular column title "Tool Cutter" and take everything listed in that column, copy it, and output it to a separate spreadsheet (all of the tools are separated by a semicolon if that helps at all).
I am trying to write a program which goes into the "Progress" folder and will loop through opening each file, copying the "Tool Cutter" values I need, outputing it to a separate Excel spreadsheet I've titled "MasterList.xlsm", closing the file, and working through all of the files in that folder until there are none left.
It would be helpful if the "MasterList.xlsm" file could have Name in column 1 and Tools in column 2.
Any advice would be very helpful! I am not an expert in VBA.
What I have been trying:
Methods with AdvancedFilter, CopyToRange, SearchString...
All of the information I am trying to grab is in a column between titles "tools" and "general setup" so this code has been somewhat helpful:
Sub LoopThroughDirectory()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyFolder As String
Dim Sht As Worksheet
Dim i As Integer
Dim LastRow As Integer, erow As Integer
'Speed up process by not updating the screen
'Application.ScreenUpdating = False
MyFolder = "C:\Users\trembos\Documents\TDS\progress\"
Set Sht = ActiveSheet
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
Set objFolder = objFSO.GetFolder(MyFolder)
i = 1
'loop through directory file and print names
For Each objFile In objFolder.Files
If LCase(Right(objFile.Name, 3)) <> "xls" And LCase(Left(Right(objFile.Name, 4), 3)) <> "xls" Then
Else
'print file name
Sht.Cells(i + 1, 1) = objFile.Name
i = i + 1
Workbooks.Open fileName:=MyFolder & objFile.Name
End If
'Range("J1").Select
'Selection.Copy
'Windows("masterfile.xlsm").Activate
'Range("D2").Select
'ActiveSheet.Paste
ActiveWorkbook.Close SaveChanges:=False
Next objFile
'Application.ScreenUpdating = True
End Sub
**The document (image attached) is not formatted them same way every time, depending on the info available sometimes column number or row number is different.

Answer 1

I would use this to get the last row/column - much faster than looping:
Function getLastRow(sheet As String, Col As Variant) As Integer
getLastRow = Sheets(sheet).Cells(Sheets(sheet).Rows.Count, Col).End(xlUp).Row
End Function
Function getLastCol(sheet As String, row As Variant) As Integer
getLastCol = Sheets(sheet).Cells(row, Sheets(sheet).Columns.Count).End(xlToLeft).Column
End Function
The full version of these functions lets you specify the workbook to check
(which is important when you are opening multiple workbooks like you plan to)
Function GetLastCol(Row As Variant, Optional Sheet As String, Optional WB As Variant) As Integer
If IsMissing(WB) Then
If Sheet = vbNullString Then
GetLastCol = Cells(Row, Columns.Count).End(xlToLeft).Column
Else
GetLastCol = Sheets(Sheet).Cells(Row, Sheets(Sheet).Columns.Count).End(xlToLeft).Column
End If
Else
If Sheet = vbNullString Then
GetLastCol = WB.ActiveSheet.Cells(Row, WB.ActiveSheet.Columns.Count).End(xlToLeft).Column
Else
GetLastCol = WB.Sheets(Sheet).Cells(Row, WB.Sheets(Sheet).Columns.Count).End(xlToLeft).Column
End If
End If
End Function
Function GetLastRow(Col As Variant, Optional Sheet As String, Optional WB As Variant) As Integer
If IsMissing(WB) Then
If Sheet = vbNullString Then
GetLastRow = Cells(Rows.Count, Col).End(xlUp).Row
Else
GetLastRow = Sheets(Sheet).Cells(Sheets(Sheet).Rows.Count, Col).End(xlUp).Row
End If
Else
If Sheet = vbNullString Then
GetLastRow = WB.ActiveSheet.Cells(WB.ActiveSheet.Rows.Count, Col).End(xlUp).Row
Else
GetLastRow = WB.Sheets(Sheet).Cells(WB.Sheets(Sheet).Rows.Count, Col).End(xlUp).Row
End If
End If
End Function
If you have a square block of data like most excel sheets, you can also use:
ActiveSheet.UsedRange.Rows.Count
ActiveSheet.UsedRange.Columns.Count
The benefit of using these functions is that you can use it like:
Range("A1:A" & GetLastRow("A"))
The rest of your find code looks okay.
Here is a function to find all files in a folder.
It returns a collection of path names that you can iterate through using a For Each loop as demonstrated below:
Private Function GetFiles(Path As String, Optional Extension As String = "*") As Collection
Dim objFSO As Object
Dim FilesReturned As Collection
Set FilesReturned = New Collection
Dim Files, File
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set Files = objFSO.GetFolder(Path).Files
On Error GoTo 0
If Files Is Nothing Then Exit Function
For Each File In Files
If UCase(objFSO.GetExtensionName(Path & File.Name)) Like UCase(Replace(Extension, ".", "")) Then
FilesReturned.Add (Path & IIf(Right(Path, 1) = "\", "", "\") & File.Name)
End If
Next File
Set GetFiles = FilesReturned
End Function
You can use this with a For Each loop to loop through each workbook.
You can open them using Workbooks.Open and use your find code like so:
(This code should go in the master sheet)
Sub GetTools()
Dim Files as Collection
On Error Resume Next
Set Files = GetFiles("C:\OurPath")
On Error GoTo 0
If Files Is Nothing Then
MsgBox ("No Files Found!")
Exit Sub
End If
'You can also use this to specify the extension if there are other types:
'Set Files = GetFiles("C:\OurPath","xls")
Dim ThisWb as Workbook
Set ThisWb = ThisWorkbook
Application.ScreenUpdating = False
For Each File In Files
Workbooks.Open File, ReadOnly:=True
'Add code to find things and copy
'We can use this line to copy from the Open Workbook, Sheet1, Range A2-A[Lastrow]
ActiveWorkbook.Sheets("Sheet1").Range("A2:A" & GetLastRow("A","Sheet1")).Copy _
ThisWb.Sheets("Sheet1").Range("A" & GetLastRow("A","Sheet1",ThisWb) + 1)
'to the bottom of our Master Sheet, column A
ActiveWorkbook.Close SaveChanges:=False
Next File
Application.ScreenUpdating = True
End Sub
Testing
I have the following files in a directory:
Tools1.xls: Tools2.xlsx":
When I run the macro on my "Master":
I am left with these results:
Edit:
If you want to add a function to your code, treat it as a separate subroutine.
For example:
Sub DoThings()
For x = 1 to 10
MsgBox(getLastRow("Sheet1",x))
Next x
End Sub
Function getLastRow(sheet As String, Col As Variant) As Integer
getLastRow = Sheets(sheet).Cells(Sheets(sheet).Rows.Count, Col).End(xlUp).Row
End Function