patternMinor
Open files, copy area under header, print to mastersheet
Viewed 0 times
headeropenmastersheetunderfilesprintareacopy
Problem
This loops through folder to open files and get important info from the columns of names "HOLDER" and "CUTTING TOOL" and printing all the info to one excel document, masterfile.
It utilizes a dictionary and collection. I am very new to VBA So I do not know if I have stayed consistent with my naming of sheets and files and using the code to make the program work as fast as possible.
Any tips on how to streamline the code more?
```
Option Explicit
Sub LoopThroughDirectory()
Const ROW_HEADER As Long = 10
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyFolder 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 RowLast As Long
Dim f As String
Dim dict As Object
Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, d 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\"
'find the headers on the sheet
Set hc1 = HeaderCell(StartSht.Range("B1"), "HOLDER")
Set hc2 = HeaderCell(StartSht.Range("C1"), "CUTTING TOOL")
'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
'(3)
'find CUTTING TOOL on the source she
It utilizes a dictionary and collection. I am very new to VBA So I do not know if I have stayed consistent with my naming of sheets and files and using the code to make the program work as fast as possible.
Any tips on how to streamline the code more?
```
Option Explicit
Sub LoopThroughDirectory()
Const ROW_HEADER As Long = 10
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyFolder 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 RowLast As Long
Dim f As String
Dim dict As Object
Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, d 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\"
'find the headers on the sheet
Set hc1 = HeaderCell(StartSht.Range("B1"), "HOLDER")
Set hc2 = HeaderCell(StartSht.Range("C1"), "CUTTING TOOL")
'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
'(3)
'find CUTTING TOOL on the source she
Solution
I've got the following points to make which are mostly about style and readability rather than the speed of the code.
-
In the
-
In the
-
In your section (5) you've got
- Why not use early binding for the Microsoft Scripting Runtime? This will let declare variables such as
FileSystemObjectand asDictionaryrather than asObject.
- Some of your functions do not state the return type, e.g.
GetLastRowInSheetandGetLastRowInColumnshould both return a Long I guess andGetValuesshould return a Dictionary.
- Variable declaration. Personally, I always declare each variable on a separate line but if you want to condense them, then I'd suggest grouping them by type. In
GetValuesyou mix variable types which makes it harder than it should to check the type of a variable.
- Variable naming. Perhaps consider using more meaningful variable names.
Dim d As Rangedoesn't really convey the meaning.
-
In the
HeaderCell function you loop through cells looking at their value. If you use the Range.Find method it will probably be much quicker. Function HeaderCell(rng As Range, sHeader As String) As Range
Set HeaderCell = rng.Parent.Range(rng, rng.Parent.Cells(rng.Row, Columns.Count).End(xlToLeft)) _
.Find(What:=sHeader, LookIn:=xlValues, LookAt:=xlPartial, MatchCase:=True)
End Function-
In the
GetLastRowInSheet function you use the WorksheetFunction and Find methods. The former is quite slow. Consider using the UsedRange property of the Worksheet object.Function GetLastRowInSheet(theWorksheet As Worksheet) As Long
With theWorksheet.UsedRange
GetLastRowInSheet = (.Row + .Rows.Count)
End With
End Function-
In your section (5) you've got
With WB ... End With but I think it doesn't add much but increases the level of indentation.Code Snippets
Function HeaderCell(rng As Range, sHeader As String) As Range
Set HeaderCell = rng.Parent.Range(rng, rng.Parent.Cells(rng.Row, Columns.Count).End(xlToLeft)) _
.Find(What:=sHeader, LookIn:=xlValues, LookAt:=xlPartial, MatchCase:=True)
End FunctionFunction GetLastRowInSheet(theWorksheet As Worksheet) As Long
With theWorksheet.UsedRange
GetLastRowInSheet = (.Row + .Rows.Count)
End With
End FunctionContext
StackExchange Code Review Q#93002, answer score: 3
Revisions (0)
No revisions yet.