I have a code that reads a text file and Text To Column. Any time I text to column I get a message "Do you want to replace the contents of the destination cells. It mean if I loop 20 times I get 20 warning messages. Can some one help me to suppress this warning message?
Code:
Sub ReadTxtLines1()
Dim shtEFH As Worksheet
Dim sht As Worksheet
Dim fso As Object
Dim fil As Object
Dim txt As Object
Dim strtxt As String
Dim tmpLoc As Long
'Dim MyTime, MyDate
Dim CurFile As String, DirLoc As String
Dim DestWB As Workbook
Dim ws As Object 'allows for different sheet types
DirLoc = "E:\Dispatch Report\" 'location of files
CurFile = Dir(DirLoc & "*.txt*")
Do While CurFile <> vbNullString
Set shtEFH = ThisWorkbook.Worksheets("Equiv_Flat_Haul")
shtEFH.Activate
firstRow = 4
Do While Cells(firstRow, 1) = ""
firstRow = firstRow + 1
Loop
firstRow = firstRow - 1
Today = Left(CurFile, 8)
startday = Format(Today, "mm - dd - yy")
'Working on active sheet
Set sht = ThisWorkbook.Worksheets("Dispatch Report")
sht.Activate
On Error Resume Next
'Clear data in the sheet
sht.UsedRange.ClearContents
'File system object that we need to manage files
Set fso = CreateObject("Scripting.FileSystemObject")
'File that we like to open and read
Set fil = fso.GetFile(DirLoc & CurFile)
' " & MyStr & "
'Opening file as a TextStream
Set txt = fil.OpenAsTextStream(1)
'Reading file include into a string variable at once
strtxt = txt.ReadAll
'Close textstream and free the file.We don 't need it anymore.
txt.Close
'Find the first placement of new line char
tmpLoc = InStr(4, strtxt, vbCrLf)
'Loop until no more new line
Do Until tmpLoc = 0
'Use A column and next empty cell to write the text file line
sht.Cells(sht.Rows.Count, 1).End(xlUp).Offset(1).Value = _
Left(strtxt, tmpLoc - 1)
' Remove the parsed line from the variable
' that we stored file include
strtxt = Right(strtxt, Len(strtxt) - tmpLoc - 1)
'Find the next placement of new line char
tmpLoc = InStr(1, strtxt, vbCrLf)
Loop
'Last line that has data but no new line char
sht.Cells(sht.Rows.Count, 1).End(xlUp).Offset(1).Value = strtxt
'It will be already released by the ending of this procedure but
' as a good habit, set the object as nothing.
Set fso = Nothing
sht.Columns("J:J").ClearContents
'sht.Columns("A:A").Select
sht.Cells(1, 1).Resize(170, 1).TextToColumns Destination:=Range("J1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(40, 9), Array(53, 9), Array(63, 1), Array(81, 9), _
Array(95, 9), Array(105, 9)), TrailingMinusNumbers:=True
sht.Columns("A:A").ClearContents
' startday = Application.InputBox(Prompt:="What is today's date (ex. 09-30-10)?", Type:=1)
'repttype = Application.InputBox(Prompt:="Month (Jan/Feb/Mar)?", Type:=2)
Clearvariables
EShvAvail = EShvAvail + Worksheets("Dispatch Report").Cells(65, 2)
EShvUA = EShvUA + Worksheets("Dispatch Report").Cells(67, 2)
Haul793Avail = Haul793Avail + Worksheets("Dispatch Report").Cells(106, 2)
Haul793UA = Haul793UA + Worksheets("Dispatch Report").Cells(108, 2)
ReadyTrucks = ReadyTrucks + Worksheets("Dispatch Report").Cells(113, 2)
EQflatHaul = EQflatHaul + Worksheets("Dispatch Report").Cells(148, 2)
CycleTime = CycleTime + Worksheets("Dispatch Report").Cells(159, 2)
TotExPit = TotExPit + Worksheets("Dispatch Report").Cells(20, 2)
rms = firstRow + Day(startday)
startdate = startday
Worksheets("Equiv_Flat_Haul").Activate
Do While Worksheets("Equiv_Flat_Haul").Cells(rms, 1) = startdate
Worksheets("Equiv_Flat_Haul").Cells(rms, 9) = EShvAvail
Worksheets("Equiv_Flat_Haul").Cells(rms, 10) = EShvUA
Worksheets("Equiv_Flat_Haul").Cells(rms, 11) = Haul793Avail
Worksheets("Equiv_Flat_Haul").Cells(rms, 12) = Haul793UA
Worksheets("Equiv_Flat_Haul").Cells(rms, 13) = ReadyTrucks
Worksheets("Equiv_Flat_Haul").Cells(rms, 19) = EQflatHaul
Worksheets("Equiv_Flat_Haul").Cells(rms, 20) = CycleTime
Worksheets("Equiv_Flat_Haul").Cells(rms, 8) = TotExPit
rms = rms + 1
Loop
CurFile = Dir
Loop
End Sub
Last edited by a moderator: