I have information that is printed from files in a folder into columns 1,2,3, and 4 of an excel sheet. Columns 1 and 2 will only ever contain one cell of information but 2 and 3 will vary in length but will be equal to each other.
My goal is to do something like if for column A, if the cell next to it in column B is occupied, go to the row below and loop, else if the cell is empty then print the info for column 1 in that row.
Here is the full code!
Option Explicit
Sub LoopThroughDirectory()
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
'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\"
'Set StartSht = ActiveSheet
Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1")
'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
'(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)
'print file name to Column 1
Workbooks.Open fileName:=MyFolder & objFile.Name
Set WB = ActiveWorkbook
'(3)
'copy HOLDER column from F11 (11, 6) until empty
LastRow = Cells(Rows.count, 1).End(xlUp).Row
Range(Cells(11, 6), Cells(LastRow, 6)).Copy
StartSht.Activate
'print HOLDER column to column 2 in masterfile in next available row
Range("B" & Rows.count).End(xlUp).Offset(1).PasteSpecial
WB.Activate
'(4)
'copy CUTTING TOOL column from F11 (11, 7) until empty
LastRow = Cells(Rows.count, 1).End(xlUp).Row
Range(Cells(11, 7), Cells(LastRow, 7)).Copy
StartSht.Activate
'print CUTTING TOOL column to column 3 in masterfile in next available row
Range("C" & Rows.count).End(xlUp).Offset(1).PasteSpecial
WB.Activate
'(5)
'print TDS information
With WB
For Each ws In .Worksheets
'print the file name to Column 1
StartSht.Cells(i + 1, 1) = objFile.Name
'print TDS name to Column 4
With ws
.Range("J1").Copy StartSht.Cells(i + 1, 4)
End With
i = i + 1
'move to next file
Next ws
'(6)
'close, do not save any changes to the opened files
.Close SaveChanges:=False
End With
End If
'move to next file
Next objFile
'turn screen updating back on
'Application.ScreenUpdating = True
ActiveWindow.ScrollRow = 1
'(7)
End Sub
My ultimate goal is for my excel sheet to look like this: (before and after)