Option Explicit
Dim Sh4LastRow 'Sheet4 LastRow
Dim Sh4Range 'Sheet4 Range
Dim Sh4Cell 'Sheet4 cell
Sub ImportFilesInFolder_DTI() 'Import "*_chr.txt files from Calypso Table files. 10.25.11 RLS
Dim rngOutput As Range
Dim blnRemoveHeader As Boolean
Dim strFile As String
Dim strFileList() As String
Dim intFile As Integer
Dim strPath As String
Dim sMyPath As String
Dim sMyFileType As String
If Left(ActiveWorkbook.Name, 6) = "AS9102" Or _
Left(ActiveWorkbook.Name, 3) = "MOT" Then
Call DynamicSheetSelect
On Error Resume Next
'C:\Program Files (x86)\Zeiss\Calypso\home\om\workarea\results
sMyPath = Application.InputBox("Enter Folder path. Example: C:\CMM Data\CMM Data Files", , _
"C:\Program Files (x86)\Zeiss\Calypso\home\om\workarea\results")
If sMyPath = "False" Then Exit Sub
On Error GoTo 0
sMyFileType = Application.InputBox("Enter File type. Example: txt = Text file, csv = Excel CSV file, xls = Excel XLS file, xlsx = Excel XLSX file, etc.", , "txt")
If sMyFileType = "False" Then Exit Sub
On Error GoTo 0
If sMyPath <> "" Or _
sMyFileType <> "" Then
strPath = sMyPath & "\"
strFile = Dir(strPath & "*_chr." & sMyFileType)
MsgBox strFile 'for testing
While strFile <> ""
intFile = intFile + 1
ReDim Preserve strFileList(1 To intFile)
strFileList(intFile) = strFile
strFile = Dir()
Wend
If intFile = 0 Then
MsgBox "No files found"
Exit Sub
End If
blnRemoveHeader = False
For intFile = 1 To UBound(strFileList)
Set rngOutput = ImportFile(strPath & strFileList(intFile), blnRemoveHeader, rngOutput)
blnRemoveHeader = False
'strFilename = Dir
Next
'Format Colum C and add Column D on sheet4
Columns("D:D").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("C:C").Activate
'Remove blank rows at cell with text "END" and Blank rows
'Remove blank rows
With Sheets("Sheet4") 'Loop thru Column A
Sh4LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set Sh4Range = .Range("A1:A" & Sh4LastRow)
End With
If Sh4LastRow <> "1" Then
Sh4LastRow = Sh4LastRow + 1
End If
Set rngOutput = Worksheets("Sheet4").Range("A" & Sh4LastRow)
For Each Sh4Cell In Sh4Range
MsgBox Sh4Cell.Address
If Sh4Cell = "" Then
Rows(Sh4Cell.Row).Select
Selection.Delete Shift:=xlUp
End If
Next Sh4Cell
'Remove rows with text, "END" in Column A
With Sheets("Sheet4") 'Loop thru Column A
Sh4LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set Sh4Range = .Range("A1:A" & Sh4LastRow)
End With
If Sh4LastRow <> "1" Then
Sh4LastRow = Sh4LastRow + 1
End If
For Each Sh4Cell In Sh4Range
If Sh4Cell = "END" Then
Rows(Sh4Cell.Row).Select
Selection.Delete Shift:=xlUp
End If
Next Sh4Cell
MsgBox UBound(strFileList) & " Files were Imported."
Else
MsgBox "User canceled the macro"
End If
Else
End If
Range("A1").Activate
End Sub
Sub DynamicSheetSelect()
Dim ws As Worksheet
Dim SheetsFound()
ReDim SheetsFound(0)
For Each ws In ActiveWorkbook.Sheets
If ws.Name <> "Sheet4" Then
Else
SheetsFound(UBound(SheetsFound)) = ws.Name
'ReDim Preserve SheetsFound(UBound(SheetsFound) + 1)
Sheets(SheetsFound).Select
End If
Next ws
'ReDim Preserve SheetsFound(UBound(SheetsFound) - 1)
If ActiveSheet.Name = "Sheet4" Then
Sheets(SheetsFound).Select
Else
MsgBox "Sheet 4 required, no files processed."
End If
End Sub
Function ImportFile(Filename As String, RemoveHeader As Boolean, Output As Range) As Range
On Error GoTo ErrImport
With Output.Parent.QueryTables.Add(Connection:="TEXT;" & Filename _
, Destination:=Output)
.Name = "XXX"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Set ImportFile = Output.Parent.Cells(Output.Parent.Rows.Count, 1).End(xlUp).Offset(2)
If RemoveHeader Then Output.EntireRow.Delete
Exit Function
ErrImport:
Set ImportFile = Nothing
Exit Function
End Function
Attached is a sample text file.
Bookmarks