boxofsorrows
03-14-2013, 09:00 AM
I'm hoping there might be someone in here kind enough to help me out. I've inherited an old spreadsheet at work that needs resurecting, however it's got a chunk of code in it that is throwing an error now that Application.Filesearch no longer is used.
I've tried to fathom out the various workarounds/replacements from the internet but with zero VB knowledge I'm getting no-where in understanding it.
This below is the subroutine that's giving the error, could anyone be kind enough to post the required amendments to make it work again in the newer Excel versions?
Many thanks in advance.
' read the file in and generate the reports
Sub Get_Data(txtDirectory As String, txtFileName As String)
On Error GoTo Err_Get_Data
Dim Direct As String
Dim FileType As String
Dim CurrentFile As String
Dim TotalFiles As String
Dim count As Single
Dim StartAddress As String
Dim StatsString As String
Dim FilesList As String
Dim FileNameOnly As String
Dim FileLoc As Single
Dim FileLength As Single
Dim R As Single
' Create the new temporary worksheets
Sheets.Add
Sheets("Sheet1").Select
Sheets("Sheet1").Name = DATA_WORKSHEET
Sheets.Add
Sheets("Sheet2").Select
Sheets("Sheet2").Name = REPORT_WORKSHEET
'clear and format sheet
Sheets(REPORT_WORKSHEET).Select
Cells.Select
Selection.ClearContents
Selection.ColumnWidth = 15
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 0
.Font.Bold = False
End With
'Capture Directory name and file type
With Application.FileSearch
.NewSearch
.LookIn = txtDirectory
.SearchSubFolders = True
.FileName = txtFileName
.Execute
TotalFiles = .FoundFiles.count
If (TotalFiles > MAX_FILES) Then
MsgBox "Max number of files exceded. Max is " + CStr(MAX_FILES)
GoTo Exit_Get_Data
End If
count = 1
Do While count < TotalFiles + 1
CurrentFile = .FoundFiles(count)
'Remove path (for stats ONLY)
FileLength = Len(CurrentFile)
FileLoc = InStrRev(CurrentFile, "\")
FileNameOnly = Right(CurrentFile, FileLength - FileLoc)
FilesList = FilesList & FileNameOnly & Chr(10)
'find where to paste
Sheets(REPORT_WORKSHEET).Select
R = 1
Do While Cells(R, 1) > ""
R = R + 1
Loop
StartAddress = "A" & R
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & CurrentFile, Destination:=Range(StartAddress))
.Name = CurrentFile
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = ","
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
count = count + 1
Loop
End With
' Hightlight the data
Rows("1:1").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Selection.Interior.ColorIndex = 41
Selection.Font.ColorIndex = 2
Selection.Font.Bold = True
Cells.Select
Selection.ColumnWidth = 25
' check that there is some data to process
If ActiveSheet.UsedRange.Rows.count = 1 Then
MsgBox "There was no data to process. Check the file(s) are in the defined directory"
GoTo Err_Get_Data
End If
' remove all the duplicate header rows
If TotalFiles > 1 Then
Dim foundCells As Range
Dim foundCell As Range
Dim findStr As Variant
Dim rowCount As Long
Dim rowId(1 To MAX_FILES) As Long
rowCount = 1
findStr = "MIEventType"
With Worksheets(REPORT_WORKSHEET).Range("A1", "A" + CStr(ActiveSheet.UsedRange.Rows.count))
Set foundCell = .Find(What:=findStr, LookIn:=xlValues)
Set foundCells = foundCell
If Not foundCell Is Nothing Then
rowId(rowCount) = foundCell.Row
Do
Set foundCells = Application.Union(foundCells, foundCell)
Set foundCell = .FindNext(After:=foundCell)
rowCount = rowCount + 1
rowId(rowCount) = foundCell.Row
Loop Until (foundCell Is Nothing) Or (foundCell.Address = "$A$1")
End If
End With
' sort array and loop through all the lines to delete then
' have to do this as I couldn't find a method of using Find that included the first line
BubbleExitSort rowId
Dim iloop As Integer
For iloop = MAX_FILES To (MAX_FILES - rowCount + 1) Step -1
Rows(rowId(iloop)).EntireRow.Delete
Next
Else
Rows(1).EntireRow.Delete
End If
' count the number of columns
Dim ColumnCount As Long
ColumnCount = 1
Dim LineCount As Long
LineCount = ActiveSheet.UsedRange.Rows.count
' clear the Data worksheet
Sheets(DATA_WORKSHEET).Select
Cells.Select
Selection.ClearContents
' format dates
FormatDate LineCount, ColumnCount
ColumnCount = ColumnCount + 1
' create records
CreateCreate LineCount, ColumnCount
ColumnCount = ColumnCount + 1
' delete records
CreateDelete LineCount, ColumnCount
ColumnCount = ColumnCount + 1
' Indexing Summary records
CreateIndexing LineCount, ColumnCount
' Create Reports
UpdateReports LineCount
' Delete the temporary worksheets
Sheets(REPORT_WORKSHEET).Select
ActiveWindow.SelectedSheets.Delete
Sheets(DATA_WORKSHEET).Select
ActiveWindow.SelectedSheets.Delete
' Check we want to mail the spreadsheet
Select Case MsgBox(prompt:="Do you want to Email the spreadsheet ?", Buttons:=vbYesNo)
Case vbNo
Exit Sub
Case vbYes
' ask for password
Dim strPassword As String
strPassword = Application.InputBox(prompt:="Enter the Password", Title:="Data sheet Password", Type:=2)
' protect the working sheets
If (strPassword <> "") Then
Dim WS As Worksheet
For Each WS In Worksheets
WS.Activate
WS.Protect Password:=strPassword
Next WS
End If
' make the sheets used invisible
Sheets("Go").Visible = False
Sheets("Constants").Visible = False
' set the mail
SendMail
End Select
Worksheets(WORKSHEET_2).Activate
Exit_Get_Data:
Exit Sub
Err_Get_Data:
MsgBox (Err.Description)
Worksheets("Go").Activate
Resume Exit_Get_Data
End Sub
I've tried to fathom out the various workarounds/replacements from the internet but with zero VB knowledge I'm getting no-where in understanding it.
This below is the subroutine that's giving the error, could anyone be kind enough to post the required amendments to make it work again in the newer Excel versions?
Many thanks in advance.
' read the file in and generate the reports
Sub Get_Data(txtDirectory As String, txtFileName As String)
On Error GoTo Err_Get_Data
Dim Direct As String
Dim FileType As String
Dim CurrentFile As String
Dim TotalFiles As String
Dim count As Single
Dim StartAddress As String
Dim StatsString As String
Dim FilesList As String
Dim FileNameOnly As String
Dim FileLoc As Single
Dim FileLength As Single
Dim R As Single
' Create the new temporary worksheets
Sheets.Add
Sheets("Sheet1").Select
Sheets("Sheet1").Name = DATA_WORKSHEET
Sheets.Add
Sheets("Sheet2").Select
Sheets("Sheet2").Name = REPORT_WORKSHEET
'clear and format sheet
Sheets(REPORT_WORKSHEET).Select
Cells.Select
Selection.ClearContents
Selection.ColumnWidth = 15
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 0
.Font.Bold = False
End With
'Capture Directory name and file type
With Application.FileSearch
.NewSearch
.LookIn = txtDirectory
.SearchSubFolders = True
.FileName = txtFileName
.Execute
TotalFiles = .FoundFiles.count
If (TotalFiles > MAX_FILES) Then
MsgBox "Max number of files exceded. Max is " + CStr(MAX_FILES)
GoTo Exit_Get_Data
End If
count = 1
Do While count < TotalFiles + 1
CurrentFile = .FoundFiles(count)
'Remove path (for stats ONLY)
FileLength = Len(CurrentFile)
FileLoc = InStrRev(CurrentFile, "\")
FileNameOnly = Right(CurrentFile, FileLength - FileLoc)
FilesList = FilesList & FileNameOnly & Chr(10)
'find where to paste
Sheets(REPORT_WORKSHEET).Select
R = 1
Do While Cells(R, 1) > ""
R = R + 1
Loop
StartAddress = "A" & R
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & CurrentFile, Destination:=Range(StartAddress))
.Name = CurrentFile
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = ","
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
count = count + 1
Loop
End With
' Hightlight the data
Rows("1:1").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Selection.Interior.ColorIndex = 41
Selection.Font.ColorIndex = 2
Selection.Font.Bold = True
Cells.Select
Selection.ColumnWidth = 25
' check that there is some data to process
If ActiveSheet.UsedRange.Rows.count = 1 Then
MsgBox "There was no data to process. Check the file(s) are in the defined directory"
GoTo Err_Get_Data
End If
' remove all the duplicate header rows
If TotalFiles > 1 Then
Dim foundCells As Range
Dim foundCell As Range
Dim findStr As Variant
Dim rowCount As Long
Dim rowId(1 To MAX_FILES) As Long
rowCount = 1
findStr = "MIEventType"
With Worksheets(REPORT_WORKSHEET).Range("A1", "A" + CStr(ActiveSheet.UsedRange.Rows.count))
Set foundCell = .Find(What:=findStr, LookIn:=xlValues)
Set foundCells = foundCell
If Not foundCell Is Nothing Then
rowId(rowCount) = foundCell.Row
Do
Set foundCells = Application.Union(foundCells, foundCell)
Set foundCell = .FindNext(After:=foundCell)
rowCount = rowCount + 1
rowId(rowCount) = foundCell.Row
Loop Until (foundCell Is Nothing) Or (foundCell.Address = "$A$1")
End If
End With
' sort array and loop through all the lines to delete then
' have to do this as I couldn't find a method of using Find that included the first line
BubbleExitSort rowId
Dim iloop As Integer
For iloop = MAX_FILES To (MAX_FILES - rowCount + 1) Step -1
Rows(rowId(iloop)).EntireRow.Delete
Next
Else
Rows(1).EntireRow.Delete
End If
' count the number of columns
Dim ColumnCount As Long
ColumnCount = 1
Dim LineCount As Long
LineCount = ActiveSheet.UsedRange.Rows.count
' clear the Data worksheet
Sheets(DATA_WORKSHEET).Select
Cells.Select
Selection.ClearContents
' format dates
FormatDate LineCount, ColumnCount
ColumnCount = ColumnCount + 1
' create records
CreateCreate LineCount, ColumnCount
ColumnCount = ColumnCount + 1
' delete records
CreateDelete LineCount, ColumnCount
ColumnCount = ColumnCount + 1
' Indexing Summary records
CreateIndexing LineCount, ColumnCount
' Create Reports
UpdateReports LineCount
' Delete the temporary worksheets
Sheets(REPORT_WORKSHEET).Select
ActiveWindow.SelectedSheets.Delete
Sheets(DATA_WORKSHEET).Select
ActiveWindow.SelectedSheets.Delete
' Check we want to mail the spreadsheet
Select Case MsgBox(prompt:="Do you want to Email the spreadsheet ?", Buttons:=vbYesNo)
Case vbNo
Exit Sub
Case vbYes
' ask for password
Dim strPassword As String
strPassword = Application.InputBox(prompt:="Enter the Password", Title:="Data sheet Password", Type:=2)
' protect the working sheets
If (strPassword <> "") Then
Dim WS As Worksheet
For Each WS In Worksheets
WS.Activate
WS.Protect Password:=strPassword
Next WS
End If
' make the sheets used invisible
Sheets("Go").Visible = False
Sheets("Constants").Visible = False
' set the mail
SendMail
End Select
Worksheets(WORKSHEET_2).Activate
Exit_Get_Data:
Exit Sub
Err_Get_Data:
MsgBox (Err.Description)
Worksheets("Go").Activate
Resume Exit_Get_Data
End Sub