swaggerbox
09-21-2015, 01:37 AM
My VBA skills are quite elementary so please go easy on me. I have a code below that extracts data from text files where filenames are listed in column C, beginning with row 18. I am getting a runtime error 91 on this line: Set oFile = fso.CreateTextFile(newName) and I am not sure why. Anyone willing to help?
Sub xTags()
Dim fso
Dim myFile As String, text As String, textline As String, posLat As Integer, posLong As Integer
Dim lastRow As Long
Dim oFile As Object
Dim fileNameOnly As String
Dim fullPathName, newName As String
Set fso = CreateObject("Scripting.FileSystemObject")
lastRow = Range("C65536").End(xlUp).Row
For Each cell In Range("C18:C" & lastRow)
myFile = cell 'Filename
If Right(UCase(myFile), 3) = "TXT" Then
Open myFile For Input As #1
Do Until EOF(1)
Line Input #1, textline
text = text & textline
Loop
Close #1
'Extract data between <ALLTAGS> and </ALLTAGS>
cellValue = text
openingParen = InStr(cellValue, "<ALLTAGS>")
closingParen = InStr(cellValue, "</ALLTAGS>")
enclosedValue = Mid(cellValue, openingParen, closingParen - openingParen)
'Get the output filename from the full path
fullPathName = myFile
fileNameOnly = Right(fullPathName, Len(fullPathName) - InStrRev(fullPathName, "\"))
fileNameOnly = FormatName(fileNameOnly)
newName = "D:\Output_Path\" & fileNameOnly & "_original.txt"
'Write the content
Set oFile = fso.CreateTextFile(newName)
oFile.WriteLine enclosedValue
oFile.Close
Set fso = Nothing
Set oFile = Nothing
End If
Next cell
End Sub
Function FormatName(ByVal txt As String) As String
Dim temp As String, x
txt = Replace(txt, "_ENGLISH-DOC", "")
txt = Replace(txt, "_ENGLISH", "")
temp = Trim(Left$(txt, InStrRev(txt, "-") - 1))
x = Split(temp, "-")
FormatName = x(UBound(x) - 1) & x(UBound(x))
End Function
Sub xTags()
Dim fso
Dim myFile As String, text As String, textline As String, posLat As Integer, posLong As Integer
Dim lastRow As Long
Dim oFile As Object
Dim fileNameOnly As String
Dim fullPathName, newName As String
Set fso = CreateObject("Scripting.FileSystemObject")
lastRow = Range("C65536").End(xlUp).Row
For Each cell In Range("C18:C" & lastRow)
myFile = cell 'Filename
If Right(UCase(myFile), 3) = "TXT" Then
Open myFile For Input As #1
Do Until EOF(1)
Line Input #1, textline
text = text & textline
Loop
Close #1
'Extract data between <ALLTAGS> and </ALLTAGS>
cellValue = text
openingParen = InStr(cellValue, "<ALLTAGS>")
closingParen = InStr(cellValue, "</ALLTAGS>")
enclosedValue = Mid(cellValue, openingParen, closingParen - openingParen)
'Get the output filename from the full path
fullPathName = myFile
fileNameOnly = Right(fullPathName, Len(fullPathName) - InStrRev(fullPathName, "\"))
fileNameOnly = FormatName(fileNameOnly)
newName = "D:\Output_Path\" & fileNameOnly & "_original.txt"
'Write the content
Set oFile = fso.CreateTextFile(newName)
oFile.WriteLine enclosedValue
oFile.Close
Set fso = Nothing
Set oFile = Nothing
End If
Next cell
End Sub
Function FormatName(ByVal txt As String) As String
Dim temp As String, x
txt = Replace(txt, "_ENGLISH-DOC", "")
txt = Replace(txt, "_ENGLISH", "")
temp = Trim(Left$(txt, InStrRev(txt, "-") - 1))
x = Split(temp, "-")
FormatName = x(UBound(x) - 1) & x(UBound(x))
End Function