title: VBA – print file name in each row until the file closes
body: <p>I have a working macro that 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.</p>
  
  <p>It currently looks like picture 1. I would like it to print the file name in column one in every row until the file closes so that for every entry in columns 2 and 3, there is also the file name entry in column one, looking like picture 2.</p>
  
  <p>I would like to apply the same thing to column 4, printing the name in every row. I don’t know if this information helps since getting the information for columns 1 and 4 is written in the same code block in section (5).</p>
  
  <p>Could someone help me figure out how to solve this problem? I have been trying to implement some sort of “i++” in that section (5) of code…but have not been successful. Thank you for any suggestions!</p>
  
  <p><img src="https://i.stack.imgur.com/luo7W.png" alt="enter image description here"></p>
  
  <p><img src="https://i.stack.imgur.com/UX8uI.png" alt="enter image description here"></p>
  
  <p><strong>FULL CODE</strong> <em>section (5) deals with the naming of the files in columns 1 and 4 of the masterfile.</em></p>
  
  <pre><code>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 &amp; objFile.Name, UpdateLinks:=0)
              Set ws = WB.ActiveSheet
  '(3)
                  'find CUTTING TOOL on the source sheet
                  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 &gt; 0 Then
                          Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
                          'add the values to the master list, column 3
                          d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
                      End If
                  Else
                      'header not found on source worksheet
                  End If
  '(4)
                  'find HOLDER on the source sheet
                  Set hc3 = HeaderCell(ws.Cells(ROW_HEADER, 1), "HOLDER")
                  If Not hc3 Is Nothing Then
  
                      Set dict = GetValues(hc3.Offset(1, 0))
                      If dict.count &gt; 0 Then
                          Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
                          'add the values to the master list, column 2
                          d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
                      End If
                  Else
                      'header not found on source worksheet
                  End If
  '(5)
              With WB
                 'print TDS information
                  For Each ws In .Worksheets
                          'print the file name to Column 1
                          StartSht.Cells(i, 1) = objFile.Name
                          'print TDS name from J1 cell to Column 4
                          With ws
                              .Range("J1").Copy StartSht.Cells(i, 4)
                          End With
                          i = GetLastRowInSheet(StartSht) + 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
  
  '(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, rng As Range, c As Range, 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 Len(v) &gt; 0 And Not dict.exists(v) Then
  
              If Not IsMissing(vSplit) Then
              spl = Split(v, ";")
  
              v = spl(0)
              End If
  
              If Not IsMissing(vSplit) Then
              spl = Split(v, ",")
  
              v = spl(0)
              End If
  
  
              dict.Add c.Address, 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
          If Trim(c.Value) = sHeader 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 &amp; .Rows.count).End(xlUp).Row
      End With
  End Function
  
  '(11)
  Function GetLastRowInSheet(theWorksheet As Worksheet)
  Dim ret
      With theWorksheet
          If Application.WorksheetFunction.CountA(.Cells) &lt;&gt; 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
  </code></pre>