Hi,

Replace your Sub CountLines with this one :

Sub CountLines(SourcePath)
  Const FileBufferSize = 50000
  Dim MyFSO As Object, MyFolder As Object, MyFile As Object
  Dim arrFile, totalFile As Long, pFile As Long, strData As String, counter As Long
  Dim lastRow As Long, lastCol As Long, isExist As Boolean, strStatusBar As String
  Dim i As Long, j As Long

  Set MyFSO = CreateObject("Scripting.FileSystemObject")
  Set MyFolder = MyFSO.GetFolder(SourcePath)
  totalFile = MyFolder.Files.Count

  ReDim arrFile(1 To totalFile, 1 To 2)
  totalFile = 0
  For Each MyFile In MyFolder.Files
      If UCase(Right(MyFile, 4)) = ".TXT" Then
         totalFile = totalFile + 1
         arrFile(totalFile, 1) = MyFile.Path  'MyFile.Name
      End If
  Next MyFile

  pFile = FreeFile
  strData = String(FileBufferSize, "#")
  For i = 1 To totalFile
      counter = 0
      Open arrFile(i, 1) For Binary Access Read As pFile
        strStatusBar = "Processing " & arrFile(i, 1) & Space(3)
        Application.StatusBar = strStatusBar
        While Not EOF(pFile)
          If Len(Application.StatusBar) < 250 Then
             Application.StatusBar = Application.StatusBar & "."
          Else
             Application.StatusBar = strStatusBar
          End If
          Get pFile, , strData
          For j = 1 To Len(strData)
              If Mid(strData, j, 1) = Chr(13) Then counter = counter + 1
          Next j
        Wend
      Close pFile
      arrFile(i, 2) = counter + 1
  Next i
  Application.StatusBar = ""

  With ActiveSheet
    .Cells(1, 1) = "Filename"
    .Cells(1, 2) = "Current Location"
    lastRow = .Cells(Cells.Rows.Count, 1).End(xlUp).Row
    lastCol = .Cells(1, Cells.Columns.Count).End(xlToLeft).Column + 1
    .Cells(1, lastCol) = Evaluate("=TEXT(NOW(),""mmmm"")")
    For i = 1 To totalFile
        isExist = False
        For j = 2 To lastRow
            If .Cells(j, 1).Value = arrFile(i, 1) Then
               .Cells(j, lastCol) = arrFile(i, 2)
               .Cells(j, 2) = SourcePath
               isExist = True
               Exit For
            End If
        Next j
        If Not isExist Then
           lastRow = lastRow + 1
           .Cells(lastRow, 1) = arrFile(i, 1)
           .Cells(j, 2) = SourcePath
           .Cells(lastRow, lastCol) = arrFile(i, 2)
        End If
    Next i
  End With
End Sub