I'm really new at taking items out of a text file and putting it into excel. I would like to look through text files, sometime 100 or more, in a specific folder and look for the word "Phone" in each file. When this word is found which is located in column two of the text file, I would like to place the whole row which the word is accociated from the text file into an excel row. In the following code I gather all text files from a specific folder and parse it out into excel. The problem is some of the files are 2 MB or greater in size and excel has a limit of how many rows are in a spreadsheet. Most of the files are left out of the worksheet because of this limitation. Any help would be appreciated. Thanks!
Code:
Function PickFolder(strStartDir As Variant) As String
'Selecting a folder to gather the text files and put into one excel spreadsheet.
Dim SA As Object, F As Object
Set SA = CreateObject("Shell.application")
Set F = SA.BrowseForFolder(0, "Choose a folder", 0, strStartDir)
If (Not F Is Nothing) Then
PickFolder = F.Items.Item.path
End If
Set F = Nothing
Set SA = Nothing
End Function
Sub V11_Folder()
Dim lrow As Long
Dim Hdrs As Long
Dim NumCols As Long
Dim ffc As Long
Dim i As Long
Dim R As Integer
Dim WBn As String
Dim rng As Range
Dim WB As Workbook
Dim WBr As Range
Dim WBlstrw As Long
Dim CurWkb As Workbook
Dim CurWks As Worksheet
Dim CurWksLrow As Long
Dim strStartDir As String
Dim UserFile As String
Dim Sht As Worksheet
Dim peach As String
On Error Resume Next
UserFile = PickFolder(strStartDir)
If UserFile = "" Then
MsgBox "Canceled"
Exit Sub
End If
Set CurWkb = Workbooks.Add
'CurWks will always refer to the Summary worksheet you are creating
Set CurWks = CurWkb.Worksheets(1)
Application.ScreenUpdating = False
'Clear out the Summary worksheet
With CurWks
.Activate
.UsedRange.Delete
End With
lrow = 1
Hdrs = 1
With Application.FileSearch
.SearchSubFolders = True
.NewSearch
'.FileName = ".xls"
.FileName = ".txt"
.LookIn = UserFile
.FileType = msoFileTypeExcelWorkbooks
.Execute
ffc = .FoundFiles.count
For i = 1 To ffc
'WB will always refer to the source Workbook that
'you are interrogating at the time
Set WB = Application.Workbooks.Open(FileName:=.FoundFiles(i))
If i = 1 Then
NumCols = WB.Sheets(1).UsedRange.Column - 1 + _
WB.Sheets(1).UsedRange.Columns.count
CurWks.Cells(Hdrs, "A").Resize(1, NumCols).Value = _
WB.Worksheets(1).Range("A1").Resize(1, NumCols).Value
End If
Application.StatusBar = "Currently Processing file " & i & " of " & ffc
WBn = WB.Name
WBlstrw = WB.Sheets(1).Cells(Rows.count, "A").End(xlUp).row
'Copy the data across
CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs, NumCols).Value = _
WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value
'Put the filename in the first Col as an index value
lrow = lrow + (WBlstrw - Hdrs)
WB.Close savechanges:=False
Next
End With
Set WB = Nothing
Set CurWks = Nothing
Set CurWkb = Nothing
Call V11_Log
End Sub
Sub V11_Log()
Dim R As Long
Dim numRows As Integer
Dim myRange As Range
Dim numR As Integer
Dim wsThis As Worksheet, wsNew As Worksheet
Dim Filter As String, title As String, msg As String
Dim i As Integer, FilterIndex As Integer
Dim FileName As Variant
'This code will allow you to select how many files you want to open and then parse them out automatically.
Application.ScreenUpdating = False
' File filters
Filter = "Excel Files (*.xls),*.xls," & _
"Text Files (*.txt),*.txt," & _
"All Files (*.*),*.*"
' Default filter to *.*
FilterIndex = 3
' Set Dialog Caption
title = "Select File(s) to Open"
' Select Start Drive & Path
ChDrive ("C")
ChDir ("C:\test")
With Application
' Set File Name Array to selected Files (allow multiple)
FileName = .GetOpenFilename(Filter, FilterIndex, title, , True)
' Reset Start Drive/Path
ChDrive (Left(.DefaultFilePath, 1))
ChDir (.DefaultFilePath)
End With
' Exit on Cancel
If Not IsArray(FileName) Then
MsgBox "No file was selected."
Exit Sub
End If
' Open Files
For i = LBound(FileName) To UBound(FileName)
Workbooks.Open FileName(i)
Set wsThis = ActiveSheet
Set myRange = wsThis.Range("A1:A5000")
numR = myRange.count
For R = 1 To numR + 1
If (wsThis.Cells(R, 2)) <> "Phone" Then
Rows(R).Select
Selection.Delete Shift:=xlUp
R = R - 1
End If
If (wsThis.Cells(R + 1, 2)) = "" Then
Exit For
End If
Next R
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select
If Cells(1, 1) = "" Then
ActiveWindow.Close False
End If
Next i
Application.ScreenUpdating = True
End Sub