Hello,
Need some help with a "run time error" problem. I think the problem is in a loop but I cannot see the problem. The first time I run everything works exactly how it should work. I try to run it for a second time everything stops. The file will open, I have to close the file tell it not to save and then try it again works fine (after every good run it stops until I open and close with out saving).
Any help would be appreciated. I have attached all my code, sorry did not know how to just attach the complete Excel file, cut paste everything into VBA should work to test. May need an htm file named:= "Seg 1" to help troubleshoot. Thanks.
Private Sub Workbook_Open()
On Error GoTo Tryagain
Call Check_For_Segments
Tryagain:
MyPath = Workbooks(ThisWorkbook.Name).Path
Workbooks(ThisWorkbook.Name).Close savechanges:=False
Call Check_For_Segments
End Sub
Option Explicit
Dim iSheet As String 'iSheet defines the segment sheet
Dim iFile As String 'iFile defines the HTM the routine is looking for
Dim MyPath As String 'MyPath defines workbook location
Dim OldTxtFile As String 'OldTxtFile defines "Mission File.txt" file
Dim pFileCount As Long 'pFileCount passes the number of files found
Dim sFile As String 'sFile passes the file name of the old text file if one exist
Public Function Check_For_Segments()
Application.Visible = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error GoTo Errorhandler
MyPath = Workbooks(ThisWorkbook.Name).Path 'Find "Full Auto Option.xls" or ThisWorkBook's (if the name is changed) location
CheckTextFileAgain:
Call TextFileName(MyPath & "\", pFileCount, sFile) 'Return file name of text file to delete
OldTxtFile = (MyPath & "\" & sFile) 'Find old OSMAP text file path and name
If sFile = "" Then
'Do Nothing
Else
If sFile <> "" Then
Kill (OldTxtFile) 'Kill will delete old OSMAP text file
If pFileCount = 1 Then
'Do nothing
ElseIf pFileCount > 1 Then
GoTo CheckTextFileAgain
End If
End If
End If
iSheet = "Segment 1"
iFile = "Seg 1.htm"
Call FileCountHTM(MyPath & "\", pFileCount)
CheckSeg1Again:
If pFileCount = 0 Then
'Do Nothing
ElseIf pFileCount >= 1 Then
Call Check_FileName_Spelling(iFile)
Call Inport_Htm(iSheet, iFile)
End If
iSheet = "Segment 2"
iFile = "Seg 2.htm"
CheckSeg2Again:
If pFileCount <= 1 Then
'Do Nothing
ElseIf pFileCount >= 2 Then
Call Check_FileName_Spelling(iFile)
Call Inport_Htm(iSheet, iFile)
End If
iSheet = "Segment 3"
iFile = "Seg 3.htm"
CheckSeg3Again:
If pFileCount <= 2 Then
'Do Nothing
ElseIf pFileCount >= 2 Then
Call Check_FileName_Spelling(iFile)
Call Inport_Htm(iSheet, iFile)
End If
iSheet = "Segment 4"
iFile = "Seg 4.htm"
CheckSeg4Again:
If pFileCount <= 3 Then
'Do Nothing
ElseIf pFileCount >= 2 Then
Call Check_FileName_Spelling(iFile)
Call Inport_Htm(iSheet, iFile)
End If
iSheet = "Segment 5"
iFile = "Seg 5.htm"
CheckSeg5Again:
If pFileCount <= 4 Then
'Do Nothing
ElseIf pFileCount >= 2 Then
Call Check_FileName_Spelling(iFile)
Call Inport_Htm(iSheet, iFile)
End If
Errorhandler:
Call Copy_OSMAPS_Data
End Function
Option Explicit
Dim StrFolder As String
Dim lCountValue As Long
Dim pFileName As String
Dim sPath As String
Dim cFileName As String
Public Function FileCountHTM(xlsPath As String, pFileCount As Long)
lCountValue = 0
StrFolder = Dir(xlsPath & "*.htm")
Do While StrFolder <> ""
lCountValue = lCountValue + 1
StrFolder = Dir
Loop
pFileCount = lCountValue
End Function
Public Function TextFileName(xlsPath As String, pFileCount As Long, sFile As String)
lCountValue = 0
sFile = ""
cFileName = ""
StrFolder = Dir(xlsPath & "*.txt")
Do While StrFolder <> ""
If StrFolder = "Metric Mission File.txt" Then
cFileName = "M"
ElseIf StrFolder = "English Mission File.txt" Then
cFileName = "E"
End If
lCountValue = lCountValue + 1
StrFolder = Dir
Loop
pFileCount = lCountValue
If cFileName = "M" Then
sFile = "Metric Mission File.txt"
ElseIf cFileName = "E" Then
sFile = "English Mission File.txt"
ElseIf cFileName = "" Then
'Do Nothing
End If
End Function
Option Explicit
Dim iTemp As String
Dim iHolder As String
Dim MyPath As String
Dim MyVar As Variant
Dim iFound As String
Dim i As Integer
Dim iMessage As String
Dim iMsgResponse As String
Public Function Check_FileName_Spelling(iFile)
Tryagain:
MyPath = ThisWorkbook.Path
MyVar = FileList(MyPath)
iFound = "Missing"
iMessage = "Check spelling of " & iFile & " file name. -YES- If file name is corrected -NO- If unable to correct file name"
For i = LBound(MyVar) To UBound(MyVar)
If MyVar(i) = iFile Then
iFound = "File Found"
Else
End If
Next
If iFound = "Missing" Then
iMsgResponse = MsgBox(iMessage, vbYesNo, "Check File Name") = vbYes
ElseIf iFound = "File Found" Then
Exit Function
End If
If iMsgResponse = True Then
GoTo Tryagain
Else
Exit Function
End If
End Function
Function FileList(iFolder As String, Optional pFile As String = "*.htm") As Variant
If Right$(iFolder, 1) <> "\" Then iFolder = iFolder & "\"
iTemp = Dir(iFolder & pFile)
If iTemp = "" Then
FileList = False
Exit Function
End If
Do
iHolder = Dir
If iHolder = "" Then Exit Do
iTemp = iTemp & "|" & iHolder
Loop
FileList = Split(iTemp, "|")
End Function
Option Explicit
Dim aSheet As String 'aSheet defines the current active sheet
Dim MyPath As String 'Find "Passive Auto XML.xls" workbook location
Dim nFile As String 'New File path changed to HTM inport format
Public Function Inport_Htm(iSheet, iFile) As String
On Error GoTo Errorhandler
aSheet = iSheet
Sheets(aSheet).Select
MyPath = Workbooks(ThisWorkbook.Name).Path
MyPath = Replace(MyPath, "\", "/")
nFile = ("FINDER;file:///" & MyPath & "/" & iFile)
With ActiveSheet.QueryTables.Add(Connection:=nFile, Destination:=Range("A1"))
.Name = "Seg 1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Call Segement_Start_Cell(aSheet)
Errorhandler:
End Function
Option Explicit
Dim iStCell As Excel.Range 'iStCell is the initial cell to look in for turn point 1 = A19
Dim lCol As Long 'lCol last columun on a particular sheet
Dim lRow As Long 'LRow last row on a particular sheet
Dim lCell As Range 'lCell puts lRow & lCol to come up with the last cell
Dim ColLtr As String 'ColLtr return the letter ID for a particular columun
Dim NewStCell As String 'NewStCell is the new start cell selected by user returned for following segements
Dim MsgResponse As Integer
Dim StrCell As String
Public Function Segement_Start_Cell(aSheet As String)
On Error Resume Next
StrCell = "$A$19"
If aSheet = "Segment 1" Then
If Sheets(aSheet).Range(StrCell).Value + Sheets(aSheet).Range(StrCell).Offset(2, 0).Value = 3 Then
Else
Application.Visible = True
Application.ScreenUpdating = True
Tryagain:
Application.Visible = True
Application.ScreenUpdating = True
Set iStCell = Application.InputBox(Prompt:="Use the mouse and select (by left clicking) the cell for Segment 1, Turn point 1.", Title:="Segment Start", Type:=8)
StrCell = iStCell.Address
If Sheets(aSheet).Range(StrCell).Value + Sheets(aSheet).Range(StrCell).Offset(2, 0).Value = 3 Then
' Do nothing
Application.Visible = True
Application.ScreenUpdating = True
Else
MsgResponse = MsgBox("Use the mouse and select start of Segment 1, Turn point 1.", vbOKCancel + vbInformation, "Segment Start")
If MsgResponse = vbOK Then
GoTo Tryagain
End If
Application.ScreenUpdating = False
Application.Visible = False
End If
Sheets("DATA").Range("$A$1").Value = iStCell.Address
Sheets("DATA").Range("$A$2").Value = iStCell
End If
Application.ScreenUpdating = False
Application.Visible = False
Else
NewStCell = Sheets("DATA").Range("$A$1").Value
If Sheets(aSheet).Range(NewStCell).Value + Sheets(aSheet).Range(NewStCell).Offset(2, 0).Value = 3 Then
Else
TryAgain2:
Application.Visible = True
Application.ScreenUpdating = True
Set iStCell = Application.InputBox(Prompt:="Select " & aSheet & " Start Cell", Title:="Segment Start", Type:=8)
If iStCell Is Nothing Then
MsgBox ("Use the mouse and select cell for " & aSheet & ", Turn point 1")
If vbOK Then
GoTo TryAgain2
End If
End If
End If
Application.ScreenUpdating = False
Application.Visible = False
End If
Call FindlRow_lCol(aSheet, lRow, lCol)
ColLtr = Split(Cells(, lCol).Address, "$")(1)
Call Select_Paste_F15(aSheet, iStCell, ColLtr, lRow, NewStCell)
End Function
Option Explicit
Dim ColLtr As String 'ColLtr returns the letter ID for a particular column
Dim cCell As String 'cCell is a place holder for Range(Last Row, Last Column)
Public Function FindlRow_lCol(aSheet As String, lRow As Long, lCol As Long) As String
Sheets(aSheet).Select
If WorksheetFunction.CountA(Cells) > 0 Then
lRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lCol = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
ColLtr = Split(Cells(, lCol).Address, "$")(1)
Range(lRow, lCol) = cCell
End If
End Function
Option Explicit
Public Function Select_Paste_F15(aSheet As String, iStCell As Range, ColLtr As String, lRow As Long, NewStCell As String)
Dim cCell As String
Dim eSeg As String
If iStCell Is Nothing Then
If aSheet = "Segment 1" Then
Range("$A$19", ColLtr & lRow).Copy
Sheets("Russian Format 15").Activate
Range("A1").Select
ActiveSheet.Paste
Else
Sheets(aSheet).Activate
Range(NewStCell, ColLtr & lRow).Copy
Sheets("Russian Format 15").Activate
cCell = Range("B1000").End(xlUp).Offset(1, 0).Row
Range("A" & cCell).Select
ActiveSheet.Paste
End If
Else
If aSheet = "Segment 1" Then
Range(iStCell, ColLtr & lRow).Copy
Sheets("Russian Format 15").Activate
Range("A1").Select
ActiveSheet.Paste
Else
Sheets(aSheet).Activate
Range(iStCell, ColLtr & lRow).Copy
Sheets("Russian Format 15").Activate
cCell = Range("B1000").End(xlUp).Offset(1, 0).Row
Range("A" & cCell).Select
ActiveSheet.Paste
End If
End If
End Function
Option Explicit
Dim cCell As String
Dim lCol As Long
Dim lRow As Long
Dim iEnd As Integer
Dim MyPath As String
Dim mFile As String
Dim nFile As String
Dim eFile As String
Dim TaskIt As Double
Public Sub Copy_OSMAPS_Data()
MyPath = Workbooks(ThisWorkbook.Name).Path
Sheets("OSMAPS Format 15").Activate
lCol = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
cCell = Split(Cells(, lCol).Address, "$")(1)
lRow = Sheets("DATA").Range("$A$3").Value
Range("A1", cCell & lRow).Select
Selection.Copy
iEnd = lRow + 1
If Sheets("OSMAPS Format 15").Range("K2").Value <= 3135 Then
mFile = MyPath
nFile = "\Metric Mission File"
Workbooks.Add (1)
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
ActiveWorkbook.SaveAs Filename:=mFile & nFile, FileFormat:=xlText, CreateBackup:=False
Workbooks("Metric Mission File.txt").Close savechanges:=True
TaskIt = Shell("Notepad.exe " & mFile & nFile, vbNormalFocus)
SendKeys "^a", True
SendKeys "^c", True
SendKeys "^v", True
SendKeys "{Backspace}", True
SendKeys "^s", True
SendKeys "%{F4}", True
GoTo CloseBook
ElseIf Sheets("OSMAPS Format 15").Range("K2").Value >= 7172 Then
mFile = MyPath
nFile = "\English Mission File"
Workbooks.Add (1)
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveWorkbook.SaveAs Filename:=mFile & nFile, FileFormat:=xlText, CreateBackup:=False
Workbooks("English Mission File.txt").Close savechanges:=True
TaskIt = Shell("Notepad.exe " & mFile & nFile, vbNormalFocus)
SendKeys "^a", True
SendKeys "^c", True
SendKeys "^v", True
SendKeys "{Backspace}", True
SendKeys "^s", True
SendKeys "%{F4}", True
GoTo CloseBook
End If
CloseBook:
Workbooks(ThisWorkbook.Name).Close savechanges:=False
Application.Visible = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
