I have code that loops through a folder to open files and get important info from the columns of names "HOLDER" and "CUTTING TOOL"by searching for the header and and printing all the info under that header into one excel document, masterfile. It also prints the file name into column 4 and the name of the "Tooling Data Sheet" to column 1.
I have code set that
'(1)
For Each objFile In objFolder.Files
With WB
'(2)
For Each ws In .Worksheets
...
''''''''''''''''code for all info I need to get from opened file'''''''''''''''''
...
Next ws
'(6)
End With
Next objFile
The problem is that it will loop through the number of ws
I have in the Workbook
but it will not switch to the next worksheet. For example, if the first worksheet in the opened file has values 1 2 3, the second worksheet has values 5 7 and the third has values 8 9 10, it will print to my masterfile 1 2 3 then 1 2 3 then 1 2 3. Thus, It only open the first one and loops through it the number of worksheets I have in that opened file but not through the worksheets themselves. Any ideas on troubleshooting this? I'm stuck.
FULL CODE
Option Explicit
Sub LoopThroughDirectory()
Const ROW_HEADER As Long = 10
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim dict As Object
Dim MyFolder As String
Dim f As String
Dim StartSht As Worksheet, ws As Worksheet
Dim WB As Workbook
Dim i As Integer
Dim LastRow As Integer, erow As Integer
Dim Height As Integer
Dim FinalRow As Long
Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, hc4 As Range, d As Range
Dim TDS As Range
Dim hc12 As Range
Dim n As Range
Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1")
'turn screen updating off - makes program faster
Application.ScreenUpdating = False
'location of the folder in which the desired TDS files are
MyFolder = "C:\Users\trembos\Documents\TDS\progress\2\"
'find the headers on the sheet
Set hc1 = HeaderCell(StartSht.Range("B1"), "HOLDER")
Set hc2 = HeaderCell(StartSht.Range("C1"), "CUTTING TOOL")
Set hc4 = HeaderCell(StartSht.Range("A1"), "TOOLING DATA SHEET (TDS):")
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
Set objFolder = objFSO.GetFolder(MyFolder)
i = 2
'loop through directory file and print names
'(1)
For Each objFile In objFolder.Files
If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then
'(2)
'Open folder and file name, do not update links
Set WB = Workbooks.Open(FileName:=MyFolder & objFile.Name, UpdateLinks:=0)
Set ws = WB.ActiveSheet
With WB
For Each ws In .Worksheets
' If Not Range("A1:A24").Find(What:="TOOL NUM", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
' Set n = ws.Cells(Rows.count, 1).End(xlUp)
'(3)
'find CUTTING TOOL on the source sheet'
If Not Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set hc = Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)
' Set n = ws.Cells(Rows.count, 1).End(xlUp)
' Set hc = HeaderCell(ws.Cells(ROW_HEADER, 1), "CUTTING TOOL")
' If Not hc Is Nothing Then
Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
If dict.count > 0 Then
'add the values to the master list, column 3
Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
Else
'StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "2"
End If
Else ' find TOOL CUTTER on sheet
'StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "NO CUTTING TOOLS PRESENT"
If Not Range("A1:M15").Find(What:="TOOL CUTTER", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set hc = Range("A1:M15").Find(What:="TOOL CUTTER", LookAt:=xlWhole, LookIn:=xlValues)
Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
If dict.count > 0 Then
'add the values to the master list, column 3
Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
Else
'StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "2"
End If
End If
End If
'(4)
'find HOLDER on the source sheet
Set hc3 = HeaderCell(ws.Cells(ROW_HEADER, 1), "HOLDER")
If Not hc3 Is Nothing Then
' If Not Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
' Set hc3 = Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues)
Set dict = GetValues(hc3.Offset(1, 0))
'If InStr(ROW_HEADER, "HOLDER") <> "" Then
If dict.count > 0 Then
'add the values to the master list, column 2
Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
Else
'StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) = "none"
End If
' find "TOOL HOLDER" on sheet
ElseIf Not Range("A1:M15").Find(What:="TOOL HOLDER", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set hc = Range("A1:M15").Find(What:="TOOL HOLDER", LookAt:=xlWhole, LookIn:=xlValues)
Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
If dict.count > 0 Then
'add the values to the master list, column 3
Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
Else
'StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "2"
End If
'End If
Else
If hc3 Is Nothing Then
StartSht.Range(StartSht.Cells(i, 2), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = "NO HOLDERS PRESENT!"
End If
End If
'(5)
'print the file name to Column 4
StartSht.Cells(i, 4) = objFile.Name
With ws
'Print TDS name by searching for header
If Not Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set TDS = Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues).Offset(, 1)
StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = TDS
Else
'print the file name wihtout the extension
StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = GetFilenameWithoutExtension(objFile.Name)
End If
i = GetLastRowInSheet(StartSht) + 1
End With
Next ws
'(6)
'close, do not save any changes to the opened files
.Close SaveChanges:=False
End With
End If
'(7)
'move to next file
Next objFile
'turn screen updating back on
Application.ScreenUpdating = True
ActiveWindow.ScrollRow = 1 'brings the viewer to the top of the masterfile
End Sub
'(8)
'get all unique column values starting at cell c
Function GetValues(ch As Range, Optional vSplit As Variant) As Object
Dim dict As Object
Dim rng As Range, c As Range
Dim v
Dim spl As Variant
Set dict = CreateObject("scripting.dictionary")
For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells
v = Trim(c.Value)
If Not dict.exists(v) Then
If Len(v) > 0 Then
'exclude any info after ";"
If Not IsMissing(vSplit) Then
spl = Split(v, ";")
v = spl(0)
End If
'exclude any info after ","
If Not IsMissing(vSplit) Then
spl = Split(v, ",")
v = spl(0)
End If
End If
dict.Add c.Address, v
End If
If Len(v) = 0 Then
v = "none"
End If
' If Len(v) = "" Then
' v = ""
' End If
Next c
Set GetValues = dict
End Function
'(9)
'find a header on a row: returns Nothing if not found
Function HeaderCell(rng As Range, sHeader As String) As Range
Dim rv As Range, c As Range
For Each c In rng.Parent.Range(rng, rng.Parent.Cells(rng.Row, Columns.count).End(xlToLeft)).Cells
'copy cell value if it contains some string "holder" or "cutting tool"
If Trim(c.Value) = sHeader Then
'If InStr(c.Value, sHeader) <> 0 Then
Set rv = c
Exit For
End If
Next c
Set HeaderCell = rv
End Function
'(10)
Function GetLastRowInColumn(theWorksheet As Worksheet, col As String)
With theWorksheet
GetLastRowInColumn = .Range(col & .Rows.count).End(xlUp).Row
End With
End Function
'(11)
Function GetLastRowInSheet(theWorksheet As Worksheet)
Dim ret
With theWorksheet
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
ret = .Cells.Find(What:="*", _
After:=.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
ret = 1
End If
End With
GetLastRowInSheet = ret
End Function
'(12)
'get the file name without the extension
Function GetFilenameWithoutExtension(ByVal FileName)
Dim Result, i
Result = FileName
i = InStrRev(FileName, ".")
If (i > 0) Then
Result = Mid(FileName, 1, i - 1)
End If
GetFilenameWithoutExtension = Result
End Function
When you use the Range
or the Cells
method, always fully qualify with the worksheet and the workbook. So your code looks like this:
With WB
For Each ws In .Worksheets
'find CUTTING TOOL on the source sheet'
If Not Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set hc = Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)
The last two lines do not state the worksheet to which the range belongs. So instead use:
With WB
For Each ws In .Worksheets
'find CUTTING TOOL on the source sheet'
If Not ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set hc = ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)
In fact, you can refine this further because you don't need to use the Find
method twice.
With WB
For Each ws In .Worksheets
'find CUTTING TOOL on the source sheet'
Set hc = ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)
If Not (hc Is Nothing) Then
There are other places in your code where you need to add the worksheet qualifier to the Range
and Cells
methods.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.