I have code that takes the contents of a Word file into a variable, so I parse the contents and handle it by VBA code.
My question is: I'm currently scanning letters by a loop, but I don't know how to find a line break.
Any help is appreciated
Thank you
This is the code I'm currently using
Sub open_word_find_text()
Dim book1 As Word.Application
Dim sheet1 As Word.Document
Set book1 = CreateObject("word.application")
book1.Visible = True
GetFilePath = Application.GetOpenFilename 'Select a file'
Filename = Mid(GetFilePath, InStrRev(GetFilePath, "\") + 1, 999):
FilePath = Mid(GetFilePath, 1, InStrRev(GetFilePath, Filename) - 2)
find_text = InputBox("Type the text you are looking for:")
file = Dir(FilePath & "\")
While (file <> "") 'loop over all the files in the folder
If InStr(file, ".docx") > 0 Then
Filename = Mid(file, InStrRev(file, "\") + 1, 999):
Set sheet1 = book1.Documents.Open(FilePath & "\" & file)
ff = sheet1.Content 'Save the contents of the file in a variable
count_result = 0
For i = 1 To Len(ff)
ff2 = Mid(ff, i, Len(find_text))
If ff2 = find_text Then
count_result = count_result + 1
MsgBox "Number result: " & count_result & vbNewLine & Mid(ff, i - 150, i + 200), vbOKCancel + vbMsgBoxRight + vbAbortRetryIgnore, Filename
End If
DoEvents
Next
b:
End If
sheet1.Close
file = Dir
DoEvents
Wend
book1.Quit
MsgBox " end!"
End Sub
I don't understand what you are trying to do, but the following will store the contents of the document in a string array by splitting on the vbCr-constant representing the line break:
Dim sLinesArr() As String
sLinesArr = Split(sheet1.Content.Text, vbCr)
The array can then be used in a loop:
Dim vLine As Variant
For Each vLine In sLinesArr
MsgBox vLine
Next
I wonder if anyone can help me.
I have a bunch of text files that contain a few thousand lines, and I just want to extract one element of each file.
A snippet of the contents of the files is like so:
<LastMassUpdateChange xsi:nil="true" />
<Notes />
<PropertyType1>House</PropertyType1>
<PropertyType2>SemiDetached</PropertyType2>
<PositionOfFlat xsi:nil="true" />
<FlatWhichFloor>0</FlatWhichFloor>
<FlatFloorsAbove>0</FlatFloorsAbove>
Where I just want to extract the text between <PropertyType2> & </PropertyType2> So in this case SemiDetached and place this result next to the file url column.
The urls of the files will all be in a column within excel, so I need a loop vba to check each text file within that column, and put the result in the next column.
I had the following code to extract the data within a certain line, but I didn't realise the files were not all formatted with the same amount of lines so it hasn't worked out.
Any help greatly appreciated, thanks.
Sub extractpropertytype()
Dim d As Integer
' For d = 1 To Sheet2.Range("G" & Rows.Count).End(xlUp).Row
For d = 2 To Range("AE1").Value + 1
'Workbooks("Book1").Activate
Open Range("AA" & d).Value For Input Access Read As #1
For i = 1 To 80
Line Input #1, X
'Range("a1").Offset(i - 1, 0).Value = x
Next i
Line Input #1, X
Range("AB" & d) = X
Close #1
Next d
End Sub
This reads all the lines into a string using a file system object and a regular expression to extract the value between the tags.
Option Explicit
Sub extractpropertytype()
Dim wb As Workbook, ws As Worksheet
Dim iRow As Long, iLastRow As Long
Dim sXML As String, sFilename As String, sPath As String
Dim Regex As Object, Match As Object
Set Regex = CreateObject("vbscript.regexp")
' capture text between tags
With Regex
.Global = True
.MultiLine = True
.IgnoreCase = True
.Pattern = "<PropertyType2>(.*)</PropertyType2>"
End With
' file system object to read text
Dim oFSO As Object, oFile As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set wb = ThisWorkbook
Set ws = Sheet2 ' change to suit
sPath = wb.Path & "\"
' scan list of text files on turn
iLastRow = ws.Range("AE1").Value + 1
For iRow = 2 To iLastRow
' open file and read all lines
sFilename = sPath & ws.Cells(iRow, "AA")
Set oFile = oFSO.OpenTextFile(sFilename, 1)
sXML = oFile.ReadAll
' extract value with regex
If Regex.test(sXML) Then
Set Match = Regex.Execute(sXML)
ws.Cells(iRow, "AB") = Match(0).submatches(0)
Else
ws.Cells(iRow, "AB") = "No match"
End If
oFile.Close
Next iRow
MsgBox iLastRow - 1 & " files scanned", vbInformation
End Sub
OK so I am having trouble trying to open a file with the name "testymctesttest_0001a.csv" then rename then save the same file with just the name "001a" to a different folder. I'm trying to do this on roughly 700 files in a given folder. Some have a letter at the end of the number (ex. 0001a) and some do not have the letter (ex 0218). Is there a way to do this without copying all the csv data into a workbook just to save that workbook as another CSV? I tried the code below and everything worked except all the newly saved CSV data was corrupted in the new folder.
Sub openSavefile()
Dim filePaths() As String
Dim lineFromFile As String
Dim lineItems() As String
Dim rowNum As Long
Dim actWkb As Workbook
Dim ary() As String
Dim ary2() As String
Dim fPath As String
Dim i As Long
Dim j As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Line1:
filePaths = selectFilesFunc
If filePaths(1) = "0" Then
Exit Sub
End If
If filePaths(1) = "-1" Then
GoTo Line1
End If
For j = 1 To UBound(filePaths)
Workbooks.Add
Set actWkb = ActiveWorkbook
Cells(1, 1).Activate
rowNum = 0
ary = Split(filePaths(j), "\")
ary2 = Split(ary(UBound(ary)), "_")
ary = Split(ary2(UBound(ary2)), ".")
Cells(1, 10).Value = ary(0)
fPath = "H:\TEST\FR2\"
Open filePaths(j) For Input As #1
Do Until EOF(1)
Line Input #1, lineFromFile
lineItems = Split(lineFromFile, ",")
If UBound(lineItems) < 4 Then
For i = 0 To UBound(lineItems)
ActiveCell.Offset(rowNum, i).Value = lineItems(i)
Next i
Else
If lineItems(7) = "HEX" Then
Range("D" & rowNum + 1 & ":G" & rowNum + 1).NumberFormat = "#"
'Range("D" & rowNum + 1 & ":G" & rowNum + 1).HorizontalAlignment = xlRight
End If
For i = 0 To UBound(lineItems)
ActiveCell.Offset(rowNum, i).Value = lineItems(i)
Next i
End If
rowNum = rowNum + 1
Loop
actWkb.SaveAs fPath & ary(0) & ".csv"
actWkb.Close
Close #1
Next j
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
The Function selectFilesFunc just gets an array of file paths to open. and the array index ary(0) just holds the new file name to be saved as (ex 0001a or 0218).
I have searched many places to find an answer and I feel like it is a simple command I am missing. But my final goal is just to open the CSV using Open filePaths(j) For Input As #1 or something similar and just save that same file with the new name and file path. But if I have to import it to a workbook to then save as a CSV, then I would like to know how to do this without corrupting the data.
Thanks for any help!
This will do it without opening the file.
It just renames the file to the text after the last underscore and moves the file from sSourceFolder to sDestinationFolder:
Public Sub RenameAndMove()
Dim colFiles As Collection
Dim vFile As Variant
Dim sFileName As String
Dim oFSO As Object
Dim sSourceFolder As String
Dim sDestinationFolder As String
Set colFiles = New Collection
sSourceFolder = "S:\DB_Development_DBC\Test\"
sDestinationFolder = "S:\DB_Development_DBC\Test1\"
EnumerateFiles sSourceFolder, "*.csv", colFiles
Set oFSO = CreateObject("Scripting.FileSystemObject")
For Each vFile In colFiles
'Get the new filename.
sFileName = Mid(vFile, InStrRev(vFile, "_") + 1, Len(vFile))
On Error Resume Next
'Move the file.
oFSO.movefile vFile, sDestinationFolder & sFileName
'You can delete this row if you want.
'It states whether the move was successful in the Immediate window.
Debug.Print vFile & " = " & (Err.Number = 0)
Err.Clear
Next vFile
End Sub
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)
Dim sTemp As String
sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub
I have the following code, which looks at each cell in column A of my spreadsheet, searches for the text it finds there in the specified PDF and then extracts the page where it finds the text as a PDF, naming it with the value in the cell of the spreadsheet. The code works but is rather slow, I may need to search for as many as 200 words in a PDF which could be as long as 600 pages. Is there a way to make the code faster? Currently it loops through each cell searches through each page looping through each word until it finds the word in the cell.
Sub test_with_PDF()
Dim objApp As Object
Dim objPDDoc As Object
Dim objjso As Object
Dim wordsCount As Long
Dim page As Long
Dim i As Long
Dim strData As String
Dim strFileName As String
Dim lastrow As Long, c As Range
Dim PageNos As Integer
Dim newPDF As Acrobat.CAcroPDDoc
Dim NewName As String
Dim Folder As String
lastrow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
strFileName = selectFile()
Folder = GetFolder()
Set objApp = CreateObject("AcroExch.App")
Set objPDDoc = CreateObject("AcroExch.PDDoc")
'AD.1 open file, if =false file is damage
If objPDDoc.Open(strFileName) Then
Set objjso = objPDDoc.GetJSObject
PageNos = 0
For Each c In Sheets("Sheet1").Range("A2:A" & lastrow)
For page = 0 To objPDDoc.GetNumPages - 1
wordsCount = objjso.GetPageNumWords(page)
For i = 0 To wordsCount
If InStr(1, c.Value, ", ") = 0 Then
If objjso.getPageNthWord(page, i) = c.Value Then
PageNos = PageNos + 1
If FileExist(Folder & "\" & c.Offset(0, 4) & ".pdf") Then
Set newPDF = CreateObject("AcroExch.pdDoc")
NewName = Folder & "\" & c.Offset(0, 4) & ".pdf"
newPDF.Open (NewName)
newPDF.InsertPages lngPages, objPDDoc, page, 1, 0
newPDF.Save 1, NewName
newPDF.Close
Set newPDF = Nothing
Exit For
Else
Set newPDF = CreateObject("AcroExch.PDDoc")
newPDF.Create
NewName = Folder & "\" & c.Offset(0, 4) & ".pdf"
newPDF.InsertPages -1, objPDDoc, page, 1, 0
newPDF.Save 1, NewName
newPDF.Close
Set newPDF = Nothing
Exit For
End If
End If
Else
If objjso.getPageNthWord(page, i) = c.Offset(0, 1).Value Then
If objjso.getPageNthWord(page, i + 1) = c.Offset(0, 2).Value Then
PageNos = PageNos + 1
If FileExist(Folder & "\" & c.Offset(0, 4) & ".pdf") Then
Set newPDF = CreateObject("AcroExch.pdDoc")
NewName = Folder & "\" & c.Offset(0, 4) & ".pdf"
newPDF.Open (NewName)
newPDF.InsertPages lngPages, objPDDoc, page, 1, 0
newPDF.Save 1, NewName
newPDF.Close
Set newPDF = Nothing
Exit For
Else
Set newPDF = CreateObject("AcroExch.PDDoc")
newPDF.Create
NewName = Folder & "\" & c.Offset(0, 4) & ".pdf"
newPDF.InsertPages -1, objPDDoc, page, 1, 0
newPDF.Save 1, NewName
newPDF.Close
Set newPDF = Nothing
Exit For
End If
Exit For
End If
End If
End If
Next i
Next page
c.Offset(0, 3).Value = PageNos
PageNos = 0
Next c
MsgBox "Done"
Else
MsgBox "error!"
End If
End Sub
Function FileExist(path As String) As Boolean
If Dir(path) <> vbNullString Then FileExist = True
End Function
Function selectFile()
Dim fd As FileDialog, fileName As String
On Error GoTo ErrorHandler
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = False
If fd.Show = True Then
If fd.SelectedItems(1) <> vbNullString Then
fileName = fd.SelectedItems(1)
End If
Else
'Exit code if no file is selected
End
End If
'Return Selected FileName
selectFile = fileName
Set fd = Nothing
Exit Function
ErrorHandler:
Set fd = Nothing
MsgBox "Error " & Err & ": " & Error(Err)
End Function
Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select the Folder where you want you new PDFs to go"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Many thanks in advance.
Loops are definitely excellent for some things, but can tie down processing with these higher queries. Recently, a colleague and I were doing a similar task (not pdf-related though), and we had much success with using a range.find method instead of a loop executing instr on each cell.
Some points of interest:
-To mimic the “loop cells” functionality when using the .find method, we ended our range statement with .cells, as seen below:
activesheet.usedrange.cells.find( )
Where the desired string goes within the ( ).
-The return value: “A Range object that represents the first cell where that information is found.”
Once the .find method returns a range, a subsequent subroutine can extract the page number and document name.
-If you need to find the nth instance of an occurrence, “You can use the FindNext andFindPrevious methods to repeat the search.” (Microsoft)
Microsoft overview of range.find:
https://msdn.microsoft.com/en-us/vba/excel-vba/articles/range-find-method-excel
So with this approach, the user can use a loop based on a count of cells in your list to execute the .find method for each string.
Downside is (I assume) that this must be done on text within the excel application; also, I’ve not tested it to determine if the string has to inhabit the cell by itself (I don’t think this is a concern).
‘===================
Another suggestion that might be beneficial is to first bulk-rip all text from the .pdf with as little looping as possible (direct actions at the document object level). Then your find/return approach can be applied to the bulk text.
I did a similar activity when creating study notes from a professor’s PowerPoints; I grabbed all the text into a .txt file, then returned every sentence containing the instance of a list of strings.
‘=====================
A few caveats: I admit that I have not executed parsing at the sheer size of your project, so my suggestions might not be advantageous in practice.
Also, I have not done much work parsing .pdf documents, as I try to opt for anything that is .txt/excel app first, and engage it instead.
Good luck in your endeavors; I hope I was able to at least provide food for thought!
Sorry to post a quick, incomplete answer, but I think I can point you in a good direction.
Instead of making the system look up the two terms hundreds of billions of times, then make hundreds of billions of comparisons, put your search terms into an array, and the text of each page into a long string.Then it only has to do one look up and 200 comparisons per page.
'Dim your Clipboard functions
Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Public Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
'...
Dim objData As New MSForms.DataObject
Dim arrSearch() As String
Dim strTxt As String
'...
'Create array of search terms
For i = 2 To lastrow
arrSearch(i - 2) = Sheets("Sheet1").Cells(1, i)
Next i
For page = 0 To objPDDoc.GetNumPages - 1
'[Move each page into a new document. You already have that code]
'Clear clipboard
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
'Copy page to clipboard
objApp.MenuItemExecute ("SelectAll")
objApp.MenuItemExecute ("Copy")
'You can also do this with the JavaScript object: objjso.ExecMenuItem("Item Name")
'You may have to insert a waiting function like sleep() here to wait for the action to complete
'Put data from clipboard into a string.
objData.GetFromClipboard
strTxt = objData.GetText 'Now you can search the entire content of the page at once, within memory
'Compare each element of the array to the string
For i = LBound(arrSearch) To UBound(arrSearch)
If InStr(1, strTxt, arrSearch(i)) > 0 Then
'[You found a match. Your code here]
End If
Next i
Next page
This is still cumbersome because you have to open each page in a new document. If there is a good way to determine which page you're on purely by text (such as the page number at the bottom of page a, followed immediately by the header at the top of page b) then you might look at copying the entire text of the document into one string, then using the clues from the text to decide which page to extract once you find a match. That would be a lot faster I believe.
Sub BatchRenameCS()
Dim objApp As Object
Dim objPDDoc As Object
Dim objjso As Object
Dim newPDF As Acrobat.CAcroPDDoc
Dim lastrow2 As Long
Dim strFileName As String
Dim Folder As String
Dim Page As Long
Dim Cell As Long
Dim PDFCharacterCount() As Long
Dim CharacterCount As Long
Dim i As Integer
Dim c As Integer
Dim x As Integer
Dim strSource As String
Dim strResult As String
Dim PDFCharacters As String
Dim PDFCharacters2 As String
Dim PDFPasteData() As String
Dim PasteDataPage As Integer
Dim LastRow As Long
Dim NewName As String
Dim NewNamePageNum As Integer
Dim Check()
Sheets("Sheet1").Range("C:D").ClearContents
strFileName = selectFile()
Folder = GetFolder()
'create array with pdf word count
Set objApp = CreateObject("AcroExch.App")
Set objPDDoc = CreateObject("AcroExch.PDDoc")
'AD.1 open file, if =false file is damage
If objPDDoc.Open(strFileName) Then
Set objjso = objPDDoc.GetJSObject
ReDim PDFCharacterCount(1 To objPDDoc.GetNumPages) As Long
For Page = 1 To objPDDoc.GetNumPages
PDFCharacters = ""
PDFCharacters2 = ""
For c = 0 To objjso.GetPageNumWords(Page - 1)
PDFCharacters = PDFCharacters & objjso.getPageNthWord(Page - 1, c)
Next c
For i = 1 To Len(PDFCharacters)
Select Case Asc(Mid(PDFCharacters, i, 1))
Case 48 To 57, 65 To 90, 97 To 122:
PDFCharacters2 = PDFCharacters2 & (Mid(PDFCharacters, i, 1))
Case Else
PDFCharacters2 = PDFCharacters2 & ""
End Select
Next
PDFCharacterCount(Page) = Len(PDFCharacters2)
Next Page
lastrow2 = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
Page = 1
ReDim PDFPasteData(1 To objPDDoc.GetNumPages) As String
For Cell = 1 To lastrow2
strResult = ""
strSource = Sheets("Sheet2").Cells(Cell, 1).Text
PDFPasteData(Page) = PDFPasteData(Page) & " " & strSource
For i = 1 To Len(strSource)
Select Case Asc(Mid(strSource, i, 1))
Case 48 To 57, 65 To 90, 97 To 122:
strResult = strResult & (Mid(strSource, i, 1))
Case Else
strResult = strResult & ""
End Select
Next
CharacterCount = CharacterCount + Len(strResult)
If CharacterCount = PDFCharacterCount(Page) Then
CharacterCount = 0
Page = Page + 1
End If
Next Cell
ReDim Check(2, objPDDoc.GetNumPages)
LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For Each LookUpCell In Worksheets("Sheet1").Range("A2:A" & LastRow)
For PasteDataPage = 1 To objPDDoc.GetNumPages
If InStr(PDFPasteData(PasteDataPage), LookUpCell.Value) Then
Check(1, PasteDataPage) = Check(1, PasteDataPage) + 1
Check(2, PasteDataPage) = Check(2, PasteDataPage) & LookUpCell.Offset(0, 1).Value & Chr(10)
If FileExist(Folder & "\" & LookUpCell.Offset(0, 1) & ".pdf") Then
Set newPDF = CreateObject("AcroExch.pdDoc")
NewName = Folder & "\" & LookUpCell.Offset(0, 1) & ".pdf"
newPDF.Open (NewName)
newPDF.InsertPages newPDF.GetNumPages - 1, objPDDoc, PasteDataPage - 1, 1, 0
newPDF.Save 1, NewName
newPDF.Close
Set newPDF = Nothing
Else
Set newPDF = CreateObject("AcroExch.PDDoc")
newPDF.Create
NewName = Folder & "\" & LookUpCell.Offset(0, 1) & ".pdf"
newPDF.InsertPages -1, objPDDoc, PasteDataPage - 1, 1, 0
newPDF.Save 1, NewName
newPDF.Close
Set newPDF = Nothing
End If
End If
Next PasteDataPage
Next LookUpCell
x = 1
For PasteDataPage = 1 To objPDDoc.GetNumPages
If Check(1, PasteDataPage) <> 1 Then
Sheets("Sheet1").Cells(x, 3) = PasteDataPage
Sheets("Sheet1").Cells(x, 4) = Check(2, PasteDataPage)
x = x + 1
End If
Next PasteDataPage
End If
MsgBox "Done"
End Sub
Function FileExist(path As String) As Boolean
If Dir(path) <> vbNullString Then FileExist = True
End Function
Function selectFile()
Dim fd As FileDialog, fileName As String
On Error GoTo ErrorHandler
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = False
If fd.Show = True Then
If fd.SelectedItems(1) <> vbNullString Then
fileName = fd.SelectedItems(1)
End If
Else
'Exit code if no file is selected
End
End If
'Return Selected FileName
selectFile = fileName
Set fd = Nothing
Exit Function
ErrorHandler:
Set fd = Nothing
MsgBox "Error " & Err & ": " & Error(Err)
End Function
Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select the Folder where you want you new PDFs to go"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
There is a code in button click where the workbooks are saved into a local text files.
workbook contains the below info:
CRITICAL; insert into ifparam
values(3498,'TAT_UNALLOCTRADESREC','STRING','IF(STRING(C5)=STRING("TCE
- External Hedge"),STRING("E"),IF(STRING(C5)=STRING("TCE - Internal Hedge"),STRING("I"),STRING(C5)))');
But output comes as CRITICAL;
insert into ifparam values(3498,'TAT_UNALLOCTRADESREC','STRING','IF(STRING(C5)=STRING(""TCE - External Hedge""),STRING(""E""),IF(STRING(C5)=STRING(""TCE - Internal Hedge""),STRING(""I""),STRING(C5)))');
Issue is where ever there is " we are getting "" in the output.
Can anyone help me in getting this as it is in the workbook i.e; single double quote " instead of ""
Please suggest if any code change needed.
Code used :
Private Sub CommandButton1_Click()
Dim xlBook As Workbook, xlSheet As Worksheet
Dim strOutputFileName As String
Dim n As Long, i As Long, j As Long
Dim MyData As String, strData() As String, MyArray() As String
Dim strPath As String
strPath = ActiveWorkbook.Path '<~~ \\plyalnppd3sm\d$\Temp\Arun\TAT\
ThisWorkbook.SaveCopyAs strPath & "\Temp.xls"
Set xlBook = Workbooks.Open(strPath & "\Temp.xls")
For Each xlSheet In xlBook.Worksheets
If xlSheet.Name <> "User_provided_data" Then
strOutputFileName = strPath & "\" & xlSheet.Name & ".zup"
xlSheet.SaveAs Filename:=strOutputFileName, FileFormat:=xlTextMSDOS
n = n + 1
ReDim Preserve MyArray(n)
MyArray(n) = strOutputFileName
Debug.Print strOutputFileName
End If
Next
xlBook.Close SaveChanges:=False
Kill strPath & "\Temp.xls"
For i = 1 To UBound(MyArray)
'~~> open the files in One go and store them in an array
Open MyArray(i) For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbCrLf)
'~~> Write to the text file
Open MyArray(i) For Output As #1
'~~> Loop through the array and check if the start and end has "
'~~> And if it does then ignore those and write to the text file
For j = LBound(strData) To UBound(strData)
If Left(strData(j), 1) = """" And Right(strData(j), 1) = """" Then
strData(j) = Mid(strData(j), 2, Len(strData(j)) - 2)
End If
Print #1, strData(j)
Next j
Close #1
Next i
End Sub
Easiest solution without looking at your code too much - Add in this line before outputting strData(j) to the text file:
strData(j) = Replace(strData(j), """""", """")
I'm sure there are nicer ways, but this is a very simple, quick and dirty fix!