I am trying to get copy information from an email saved as a .txt file to an excel sheet.
The issues I am running in to is when I use a Do Loop with the Line Input function I can not get information from text lines that are not on the current line. I would also like the code to copy the line containing the deliminator.
This is the code I am using:
intFreefile = FreeFile
Open ThisWorkbook.Path & "\temp567.txt" For Input As #intFreefile
lngRecordsInEmail = 0
Do Until EOF(intFreefile)
Line Input #intFreefile, strText
If InStr(1, strText, strDelimiter) > 0 Then
If InStrRev(1, strText, strDelimiter) = 1 Then
' if last character in line = deliminator then
' how do i get the text on 2 lines below?
Else
ws.Cells(lngRow, 1).Value = strText
End If
If blColourCell Then
ws.Cells(lngRow, 1).Interior.ColorIndex = 35
End If
strText2 = strText2 + 1
lngRow = lngRow + 1
lngTotalRecords = lngTotalRecords + 1
lngRecordsInEmail = lngRecordsInEmail + 1
End If
Loop
Close
My favorite method which is also faster than looping through the file contents is to read the entire text from the file into an array in one go and then work with the array. This will also give you more control to retrieve text from the 2 lines that you want.
Is this what you are trying? (Untested)
Dim MyData As String, strData() As String
Dim i As Long
intFreefile = FreeFile
'~~> Open file and read it on one go
Open ThisWorkbook.Path & "\temp567.txt" For Binary As #intFreefile
MyData = Space$(LOF(1))
Get #intFreefile, , MyData
Close #intFreefile '<~~ Close the text file after reading from it
'~~> This array has the entire contents from the text file
strData() = Split(MyData, vbCrLf)
For i = LBound(strData) To UBound(strData)
'~~> Last character in line = deliminator
If Right(strData(i), 1) = strDelimiter Then
Debug.Print strData(i)
Debug.Print strData(i + 1)
Debug.Print strData(i + 2)
'~~> Else if the deliminator is somewhere else
ElseIf InStr(1, strData(i), strDelimiter) Then
Debug.Print strData(i)
End If
Next i
Related
I want to copy some texts from a sheet to another. For example: 01/02/2021 .
However VBA automatically convert it to 2020/01/02. How can I stop it?
The following codes didn't work.
Example1:
sheet_1.Range("A1:A" & sheet1.Cells(1, 1).CurrentRegion.End(xlDown).row).Copy
ws.Range("start").PasteSpecial xlPasteValues
ws.Range("start").PasteSpecial xlPasteFormats
Example2:
sheet_1.Range("A1:A" & sheet1.Cells(1, 1).CurrentRegion.End(xlDown).row).Copy
ws.Range("start").PasteSpecial xlPasteFormulasAndNumberFormats
Example3:
sheet_1.Range("A1:A" & sheet1.Cells(1, 1).CurrentRegion.End(xlDown).row).Copy
ws.Range("start").Paste xlPaste Format:="Text" 'This causes an error
Please, try the next code. It will extract the date from the (pseudo) xls file and place it in the first column of the active sheet. Correctly formatted as date:
Sub openXLSAsTextExtractDate()
Dim sh As Worksheet, arrTXT, arrLine, arrD, arrDate, fileToOpen As String, i As Long, k As Long
Set sh = ActiveSheet 'use here the sheet you need
fileToOpen = "xls file full name" 'use here the full name of the saved xls file
'put the file content in an array splitting the read text by end of line (vbCrLf):
arrTXT = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(fileToOpen, 1).ReadAll, vbCrLf)
ReDim arrDate(UBound(arrTXT)) 'redim the array where the date will be kept, to have enough space for all the date values
For i = 39 To UBound(arrTXT) - 1 'iterate between the array elements, starting from the row where date data starts
arrLine = Split(arrTXT(i), vbTab) 'split the line by vbTab
arrD = Split(arrLine(0), "/") 'split the first line element (the date) by "/"
arrDate(k) = DateSerial(arrD(2), arrD(1), arrD(0)): k = k + 1 'properely format as date and fill the arrDate elements
Next i
ReDim Preserve arrDate(k - 1) 'keep only the array elements keeping data
With sh.Range("A1").Resize(UBound(arrDate) + 1, 1)
.value = Application.Transpose(arrDate) 'drop the array content
.NumberFormat = "dd/mm/yyyy" 'format the column where the date have been dropped
End With
End Sub
Edited:
You did not say anything...
So, I made a code returning the whole table (in the active sheet). Please, test it. It will take only some seconds:
Sub openXLSAsText()
Dim sh As Worksheet, arrTXT, arrLine, arrD, arrData, fileToOpen As String, i As Long, j As Long, k As Long
Set sh = ActiveSheet 'use here the sheet you need
fileToOpen = "xls file full name" 'use here the full name of the saved xls file
'put the file content in an array splitting the read text by end of line (vbCrLf):
arrTXT = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(fileToOpen, 1).ReadAll, vbCrLf)
ReDim arrData(1 To 10, 1 To UBound(arrTXT)) 'redim the array where the date will be kept, to have enough space for all the date values
For i = 38 To UBound(arrTXT) - 1 'iterate between the array elements, starting from the row where table header starts
arrLine = Split(arrTXT(i), vbTab) 'split the line by vbTab
k = k + 1 'increment the k variable (which will become the table row)
For j = 0 To 9
If j = 0 And k > 1 Then
arrD = Split(arrLine(j), "/") 'split the first line element (the date) by "/"
arrData(j + 1, k) = DateSerial(arrD(2), arrD(1), arrD(0)) 'propperely format as date and fill the arrDate elements
ElseIf j = 2 Or j = 3 Then
arrData(j + 1, k) = Replace(arrLine(j), ",", ".") 'correct the format for columns 3 and four (replace comma with dot)
Else
arrData(j + 1, k) = arrLine(j) 'put the rest of the column, not processed...
End If
Next j
Next i
ReDim Preserve arrData(1 To 10, 1 To k) 'keep only the array elements with data
With sh.Range("A1").Resize(UBound(arrData, 2), UBound(arrData))
.value = Application.Transpose(arrData) 'drop the array content
.EntireColumn.AutoFit 'autofit columns
.Columns(1).NumberFormat = "dd/mm/yyyy" 'format the first column
End With
MsgBox "Ready..."
End Sub
I was trying to write a sub to rewrite line 27 of a text file. But the EOF(1) seems only work 10% of the time. Other times it just directly run down with the 1st loop, and returns nothing. Anyone know the reason?
Dim File As String
Dim VecFile() As String, Aux As String
Dim i As Long, j As Long
Dim SizeNewFile As Long
Open (filepath) For Input As 1
i = 0
j = 0
Do Until EOF(1)
j = j + 1
Line Input #1, Aux
If j <> 27 Then
i = i + 1
ReDim Preserve VecFile(1 To i)
VecFile(i) = Aux
End If
Loop
Close #1
SizeNewFile = i
'Write array to file
Open ("filepath") For Output As 1
For i = 1 To 26
Print #1, VecFile(i)
Next i
Print #1, "\newcommand\casenumber{" & Sheets("Database").Range("$B$1").Value & "}" & Chr(13) & Chr(10)
For i = 28 To SizeNewFile
Print #1, VecFile(i)
Next i
Close #1
I got Run time error 9, subscript out of range.
Try something like this instead:
Sub Tester()
Const FILE_PATH As String = "C:\Tester\Modify Me.txt"
Dim arr, txt
With CreateObject("scripting.filesystemobject")
txt = .opentextfile(FILE_PATH, 1).readall() 'read all content
arr = Split(txt, vbCrLf) 'zero-based array from file content
'modify content if reached required # of lines
If UBound(arr) >= 26 Then arr(26) = "---New line goes here---"
txt = Join(arr, vbCrLf)
.opentextfile(FILE_PATH, 2, True).write txt 'write back modified text
End With
End Sub
I'm working on a 5 sheet workbook, where a button named ExportCSV on sheet 5 exports data on sheet 3. More specifically, the button runs a VBA code that goes row by row and checks the first 3 cells for data. If any of the first three cells have data, then the whole row is selected. After all rows with data are selected, the data is written row by row to a CSV file (the file itself is semicolon-delimited, however).
The problem that I'm having is that some cell formatting is being copied over, but some is not. For example, values in cells formatted for Accounting with a $ are formatted correctly, meaning "$12,345,678.90" shows up as "$12,345,678.90." However, values in cells formatted as Accounting but without $ are not being written to the csv correctly, meaning "12,345,678.90" is being written as "12345678.9."
Below is the Macro in question.
Dim planSheet As Worksheet
Dim temSheet As Worksheet
Private Sub ExportCSV_Click()
Dim i As Integer
Dim j As Integer
Dim lColumn As Long
Dim intResult As Integer
Dim strPath As String
On Error GoTo Errhandler
Set temSheet = Worksheets(3)
i = 2
Do While i < 1001
j = 1
Do While j < 4
If Not IsEmpty(temSheet.Cells(i, j)) Then
temSheet.Select
lColumn = temSheet.Cells(2, Columns.Count).End(xlToLeft).Column
temSheet.Range(temSheet.Cells(2, 1), temSheet.Cells(i, lColumn)).Select
End If
j = j + 1
Loop
i = i + 1
Loop
Application.FileDialog(msoFileDialogFolderPicker).InitialFileName = Application.ActiveWorkbook.Path
Application.FileDialog(msoFileDialogFolderPicker).Title = "Select a Path"
Application.FileDialog(msoFileDialogFolderPicker).ButtonName = "Select Path"
intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
If intResult <> 0 Then
'dispaly message box
strPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
End If
Dim X As Long, FF As Long, S() As String
ReDim S(1 To Selection.Rows.Count)
For X = 1 To Selection.Rows.Count
S(X) = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(Selection.Rows(X).Value)), ";")
Next
FF = FreeFile
FilePath = strPath & "\Data" & Format(Now(), "yyyyMMddhhmmss") & ".csv"
Open FilePath For Output As #FF
Print #FF, Join(S, vbNewLine)
Close #FF
Errhandler:
...Error Handling Code omitted
End Sub
I need to be able to copy over the exact formatting of the cells. Converting the no-$ cells to $ cells won't work because the values without $ are being used for a calculation later on in the process that can handle the commas, but not a $, and I can't change the code for the later calculation (proprietary plug-in doing the calculation.) Also, the rows have mixed content, meaning some values in the row are text instead of numbers.
I ended up following David Zemens' advice and overhauled the section that was For X = 1 to Selection.Rows.Count See below.
For X = 1 To Selection.Rows.Count
For Y = 1 To Selection.Columns.Count
If Y <> Selection.Columns.Count Then
If IsNumeric(temSheet.Cells(X + 1, Y).Value) Then
If temSheet.Cells(X + 1, Y).Value = 0 Then
S(X) = S(X) & ";"
Else
S(X) = S(X) & Replace(temSheet.Cells(X + 1, Y).Text, " ", "") & ";"
End If
Else
S(X) = S(X) & Trim(temSheet.Cells(X + 1, Y).Text) & ";"
End If
Else
If IsNumeric(temSheet.Cells(X + 1, Y).Value) Then
If temSheet.Cells(X + 1, Y).Value <> 0 Then
S(X) = S(X) & Replace(temSheet.Cells(X + 1, Y).Text, " ", "")
End If
Else
S(X) = S(X) & Trim(temSheet.Cells(X + 1, Y).Text)
End If
End If
Next
Next
Some more formatting was necessary. It goes cell by cell, purposefully skipping the first row of the sheet. The .Text property of some of the cells returned empty space before the value or between the $ and value, so it had to be removed. Trim removes leading and ending spaces while Replace replaces all spaces in the export.
I am having some content in Sheet1 and I am doing some manipulations and writing them in Sheet2.
The objective is to write the Sheet2 into a .txt file. The range is always going to be A1:A2320 from Sheet2. So I loop and print them in the output file.
The problem I face is post manipulation there are a set of blank lines getting into the output file and it is always having 2321 lines (This is expected as per my code). I need to remove all subsequent blank lines in the range A1:A2320 before printing, only if there is more than one continuous blank.
For Example if this is the sheet Temp after manipulation
A
B
C
D
E
.
This should be written as
A
B
C
D
E
.
This is what I made so far
Private Sub Make_Click()
Dim numFields As Integer
Dim numRows As Integer
Dim curField As Integer
Dim curRow As Integer
Dim tmpText As String
Dim outputFile As Variant
numFields = 1
numRows = 2320
curField = 1
curRow = 1
outputFile = Application.GetSaveAsFilename(InitialFileName:=ActiveWorkbook.Path _
& "\", filefilter:="Text Files (*.txt), *.txt", _
Title:="Output file name (will overwrite)")
If outputFile = False Then
Exit Sub
End If
On Error GoTo failed
Open outputFile For Output As #1
For curRow = 1 To numRows
For curField = 1 To numFields
tmpText = ActiveWorkbook.Sheets("Temp").Cells(curRow, curField).Value
Print #1, tmpText;
If curField < numFields Then
Print #1, vbTab;
End If
Next curField
Print #1, vbLf;
Next curRow
Close #1
MsgBox "File " & outputFile & " written. " & numFields & " fields, " & numRows & " rows."
Exit Sub
failed:
On Error Resume Next
Close #1
MsgBox "Couldn't create/overwrite file."
End Sub
If you are only dealing with one column of data, then checking for blanks is trivial. And if you are always only dealing with column A, why are you stepping through columns? You could use a counter to keep track of how many blank lines you have in a row...
Dim counter As Integer
counter = 0
...
For curRow = 1 To numRows
tmpText = ActiveWorkbook.Sheets("Temp").Cells(curRow, 1).Value
If Len(tmpText) > 0 Then
If counter = 1 Then
Print #1, vbLf
End If
Print #1, tmpText
Print #1, vbLf
counter = 0
Else
counter = counter + 1
End If
Next curRow
We just delay printing the single blank line until we find the next non-blank. Now if you want to keep a single blank when it occurs on the last row, you will need to stick an if statement on the end of this code.
Can someone please confirm why my macro jumps out of loop. I am not getting why its happening.
My Input looks like this http://i.imgur.com/Y6XRBai.jpg
What I am trying is split the text and write to textfile from column D2 onwards using while loop, First file writes properly but when it starts writing second file either for loop or if condition breaks out and macro comes to line where strDir starts
Sub SplitTextAndSave()
'Macro to split text and write to text file
'Full name of File name will be Single quote + Prefix from B2 + ( + filename from C2 + )'
'Application.DisplayAlerts = False
Dim Val, splitVal As String
Dim reqNumTxt, totLn, reqNum, remChr, i As Integer
Dim wb As Workbook
Dim strFile, fileNm, strDir As String
Set Sheet = Excel.ActiveSheet
' Select where to place the files
Dim obj As Object
Dim path As String
Set obj = CreateObject("Shell.Application").browseforfolder(0, "Please Select Folder where TWS scripts will be created", 0)
On Error GoTo error_trap:
path = obj.self.path & "\"
error_trap:
'this is where it starts again when the loop breaks
strDir = path
filepre = Sheet.Cells(2, 2).Value
reqNum = Sheet.Cells(3, 2).Value
reqNumTxt = 0
Sheet.Cells(2, 4).Activate
Do While ActiveCell.Value <> ""
Set nextcell = ActiveCell.Offset(1, 0)
fileNm = ActiveCell.Offset(0, -1).Value
FileFullNm = strDir & "'" & filepre & "(" & fileNm & ")'"
Open FileFullNm For Output As #1
Val = ActiveCell.Value
totLn = Int(Len(Val) / reqNum)
remChr = Len(Val) Mod reqNum
If Len(Val) <= reqNum Then
Print #1, Val
Close #1
Else
For i = 1 To totLn
'I observed sometimes loop breaks here
splitVal = Left(Right(Val, Len(Val) - reqNumTxt), reqNum)
Print #1, splitVal
reqNumTxt = reqNumTxt + reqNum
Next i
If remChr = 0 Then
Close #1
Else
'most of the time loop break here when writing second file
splitVal = Left(Right(Val, Len(Val) - reqNumTxt), reqNum)
Print #1, splitVal
Close #1
End If
End If
nextcell.Select
Set currentcell = nextcell
'Next
Loop
MsgBox "Done"
'Application.DisplayAlerts = True
End Sub
I added 2 lines to your code and it runs without error. I set splitVal to null and reqNumTxt to zero.
Val = ActiveCell.Value
totLn = Int(Len(Val) / reqNum)
remChr = Len(Val) Mod reqNum
**splitVal = ""**
If Len(Val) <= reqNum Then
Print #1, Val
Close #1
Else
For i = 1 To totLn
'I observed sometimes loop breaks here
splitVal = Left(Right(Val, Len(Val) - reqNumTxt), reqNum)
Print #1, splitVal
reqNumTxt = reqNumTxt + reqNum
Next i
If remChr = 0 Then
Close #1
Else
'most of the time loop break here when writing second file
splitVal = Left(Right(Val, Len(Val) - reqNumTxt), reqNum)
Print #1, splitVal
Close #1
End If
End If
nextcell.Select
Set currentcell = nextcell
**reqNumTxt = 0**
Loop