I have an excel file that is importing pricing from various txt files that are automatically generated by a third party. I hit a road block with one of the txt files because it uses space delimited whereas the others use tab. Because of the space delimited, when i split the data i get different values in each column.
Here is what I have so far to open and read the text file
usFileName = PathName & "\" & "Prices.txt"
If fs.FileExists(usFileName) Then
Set US = fs.OpenTextFile(usFileName, 1)
theData = US.ReadLine
getDate = Split(theData, Chr(0))
curDate = Trim(Left(getDate(0), 10))
If curDate = ActiveSheet.Range("Sheet_Date") Then
Do While Not US.AtEndOfStream
On Error Resume Next
Ln = US.ReadLine
Cols = Split(Ln, " ")
Price = Trim(Cols(7))
NameTrim = Trim(Replace(Cols(1), "USO-", ""))
CellName = Replace(NameTrim, "-", "_") & "_" & Trim(Cols(2))
If ActiveSheet.Range(CellName) Is Nothing Then
''Do Nothing here
On Error Resume Next
Else
Set TxtRng = ActiveSheet.Range(CellName)
If TxtRng = ActiveSheet.Range(CellName) Then
TxtRng.Value = Price
End If
End If
Loop
Else
MsgBox ("The current sheet date does not match the US file import date.")
End If
US.Close
Else
MsgBox ("The file Prices.txt does not exist.")
End If
This is what the txt file looks like:
01/11/2019 06:00 PM USO-FOX-USO E10 8.9929 0.0000
01/11/2019 06:00 PM USO-FOX-USO CON8HE10 1.3212 -0.0244
01/11/2019 06:00 PM USO-FOX-USO CON8HE10TT 1.3232 -0.0244
And this is what the Cols variable looks like.
Try
Sub Test()
Dim PathName As String
Dim usFileName As String
PathName = "Your path"
usFileName = PathName & "\" & "Prices.txt"
Workbooks.OpenText Filename:=usFileName, _
StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), _
Array(19, 1), Array(32, 1), Array(48, 1), Array(55, 1))
End Sub
You can try removing spaces and replacing them this way:
Ln = US.ReadLine
Do While (InStr(Ln, " ") > 0)
Ln = Replace(Ln, " ", " ")
Loop
'The only problem I see is the case where you have Time (6:00 PM) this
' would replace the space with Tab. in that case, I would do the following:
Ln = Replace(Ln, " PM", "PM")
Ln = Replace(Ln, " AM", "AM")
Ln = Replace(Ln, " ", vbTab)
'And then put them back
Ln = Replace(Ln, "PM", " PM")
Ln = Replace(Ln, "AM", " AM")
'Finally, split the columns
Cols = Split(Ln, vbTab)
If you want to try with fixed width then do the following (after Ln = US.Readline):
'01/11/2019 06:00 PM USO-FOX-USO E10 8.9929 0.0000
'Do the following only if (InStr(Ln, " ") > 0)
strCol1 = Mid(Ln, 1, 21)
strCol2 = Mid(Ln, 22, 13)
strCol3 = Mid(Ln, 35, 13)
strCol4 = Mid(Ln, 48, 11)
strCol5 = Mid(Ln, 59, Len(Ln))
Related
I have a problem with the date format in the new exported csv file.
If I export a range from an excel file, then the date format is dd/mm/yyyy but i need dd/mm/yyyy hh:nn.
If I changed the format in the original excel file to the right form, then the most values in the csv show the right format except the date-value e.g. 18.08.2021 00:00.
So if the time is 00:00 then only the dd/mm/yyyy format appears at that row and this format is incompatible to the database.
(i opened it in excel and in the editor and it appeared the same problem)
can someone help me?
Dim ws As Worksheet, fd As FileDialog, rngTest As Range, rngExport As Range, fltr As FileDialogFilter
Dim start As Long
start = 2
'Nach jeweiliger Zeit wird Datenreihe (start ab) ausgewählt
If Time < TimeValue("11:15") Then
Do Until Daten.Range("ov" & start) = Date + 1
start = start + 1
Loop
ElseIf Time < TimeValue("11:15") Then
Do Until Daten.Range("ov" & start) = Date + 2
start = start + 1
Loop
Else: start = 2
End If
start = start + 1
'Worksheet auf dem die Daten stehen
Set ws = Worksheets("Daten")
'Zelle die auf Inhalt überprüft werden soll
Set rngTest = ws.Range("ov2")
'Bereich der exportiert wird
Set rngExport = ws.Range("ov" & start & ":ow10000")
' ws.Range("ov" & start & ":ov5000").NumberFormat = "dd/mm/yyyy hh:mm"
If rngTest.Text <> "" Then
Set fd = Application.FileDialog(msoFileDialogSaveAs)
'Filename
fd.InitialFileName = "LG" & " " & Diagramm.Range("a5").Value & " " & "RZ" & " " & Format(Date, "mmmm") & " " & Format(Date, "yyyy") & "_" & "MW" & "_" & "ab" & " " & Daten.Range("ov" & start - 1).Value
' Application.Dialogs(xlDialogSaveAs).Show filenameComplete
With fd
.Title = ""
'Filterindex für CSV-Dateien ermitteln
For i = 1 To .Filters.count
If .Filters(i).Extensions = "*.csv" Then
.FilterIndex = i
Exit For
End If
Next
'Wenn OK geklickt wurde starte Export
If .Show = True Then
ExportRangeAsCSV rngExport, ";", .SelectedItems(1)
End If
End With
End If
End Sub
'Hier werden die Werte in eine CSV-Datei eingefügt und gespeichert
Sub ExportRangeAsCSV(ByVal rng As Range, delim As String, filepath As String)
Dim arr As Variant, line As String, csvContent As String, fso As Object, csvFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set csvFile = fso.OpenTextFile(filepath, 2, True)
arr = rng.Value 'Filter
If IsArray(arr) Then
' um die Überschrift im CSV oben einzufügen
Dim col As Range
For Each col In rng.Columns
If Len(line) > 0 Then line = line & delim
line = line & """" & rng.Parent.Cells(1, col.column) & """"
Next
csvContent = line & vbNewLine
'um die Werte ins CSV einzufügen
For r = 1 To UBound(arr, 1)
line = ""
For c = 1 To UBound(arr, 2)
If c < UBound(arr, 2) Then
line = line & """" & arr(r, c) & """" & delim
Else
line = line & """" & arr(r, c) & """"
End If
Next
csvContent = csvContent & line & vbNewLine
Next
csvFile.Write (csvContent)
csvFile.Close
Else
MsgBox "Bereich besteht nur aus einer Zelle!", vbExclamation
End If
Set fso = Nothing
Set csvFile = Nothing
End Sub
The Range("ov").value is the date and Range("ow").value the amount (double)
As you are already writing the CSV-File manually, I would suggest to introduce a function that converts your cell content as a string. You could use this routine for multiple purposes, eg format numbers (decimals, number of digits...), get rid of unwanted characters in as string (eg Newlines, semicolon, quote characers)...
Just to give you an idea:
Function FormatCellValue(v As Variant) As String
If IsDate(v) Then
FormatCellValue = Format(v, "dd.mm.yyyy hh:mm")
ElseIf VarType(v) = vbDecimal Then
FormatCellValue = Format(v, "#####.00")
ElseIf VarType(v) = vbString Then
v = Replace(v, vbCr, " ")
v = Replace(v, vbLf, " ")
v = Replace(v, ";", ",")
v = Replace(v, """", "'")
FormatCellValue = v
Else
FormatCellValue = v
End If
End Function
And in your existing code, simply write
line = line & """" & FormatCellValue(arr(r, c)) & """"
Update
If you want to write only strings with quote and dates (and numbers) without, you could add the quotes in the FormatCell-function: In the Vartype = vbString-branch, write
FormatCellValue = """" & v & """"
and change the call to
line = line & FormatCellValue(arr(r, c))
Excel really sucks at formatting numbers because the internal systems keep the stored value and displayed value separately. So what you see is not what will end up in the file when you save. To force excel to actually apply the formatting to the stored value, I use quotes to turn numbers & dates into strings. Like [A1].formula = "=""" & [A1].Value & """" which would turn a cell containing the number 100.00 into ="100.00" a literal string that excel can't reformat.
For your date format situation, you can do [A1].formula = "=""" & Format([A1].Value, "dd/mm/yyyy hh:nn") & """". Which will force excel to save the cell value in the specified format and ensure the output csv is in that format.
Here is a function that I have used previously to change a 2D array of values into an array of formulas as described above.
Private Function ForceString(ByRef InputArr As Variant) As Variant
Dim OutputArr() As Variant
OutputArr = InputArr
Dim i As Long, j As Long
For i = LBound(OutputArr) To UBound(OutputArr)
For j = LBound(OutputArr, 2) To UBound(OutputArr, 2)
If Len(OutputArr(i, j)) < 255 Then
OutputArr(i, j) = "=""" & OutputArr(i, j) & """"
Else
Dim k As Long, Tmp As String
Tmp = "="
For k = 1 To Len(OutputArr(i, j)) Step 255
Tmp = Tmp & IIf(k <> 1, "&", "") & """" & Mid(OutputArr(i, j), 1, 255) & """"
Next k
OutputArr(i, j) = Tmp
End If
Next j
Next i
ForceString = OutputArr
End Function
The If/Else in the middle is due to the limitation in excel about a literal string inside a formula not being allowed to have more than 255 characters. In those cases, it just has to be split up into multiple strings, but the output value is still the same.
i want to implement this recorded macro into a macro for my code, i succesfully transformed "E" row into general, and i want to change that date into Short Date format DD/MM/YYYY the macro i recorded is this one below:
Sub Macro2()
'
' Macro2 Macro
Range("L4").Select
ActiveCell.FormulaR1C1 = "=DATEVALUE(MID(RC[-7],1,10))"
Range("L4").Select
Selection.AutoFill Destination:=Range("L4:L4500"), Type:=xlFillDefault
Range("L4:L4500").Select
Selection.NumberFormat = "m/d/yyyy"
End Sub
I tried it by making the function into the L Column, if it is possible i would like to implement it in one column so all values change and then paste them into the E column
The whole E column is like this:
01-10-2019 52:59:76
02-10-2019 52:59:76
02-10-2019 52:59:76
05-10-2019 52:59:76
And i want them to change into
01/10/2019
02/10/2019
02/10/2019
05/10/2019
This the code i used to transform the whole E column data to the format of dd-mm-yyyy hh:mm:ss to correct the error of some data not changing into the correct format
With ActiveSheet.UsedRange.Columns("E").Cells
Columns("E").NumberFormat = "0"
Columns("E").NumberFormat = "General"
End With
If in '01-10-2019 52:59:76' first two digits means day, try please the next code:
Sub testDateFormat()
Dim lastRow As Long, sh As Worksheet, x As String, i As Long
Set sh = ActiveSheet 'use here your sheet, if not active one
lastRow = sh.Range("E" & sh.Rows.count).End(xlUp).Row
sh.Range("E1:E" & lastRow).NumberFormat = "dd/mm/yyyy"
For i = 2 To lastRow
If sh.Range("E" & i).Value <> Empty Then
If chkFind(CStr(sh.Range("E" & i).Value)) = True Then
x = CStr(sh.Range("E" & i).Value)
sh.Range("E" & i).Value = Format(DateSerial(Split(left(x, WorksheetFunction.Find(" ", x) - 1), "-")(2), _
Split(left(x, WorksheetFunction.Find(" ", x) - 1), "-")(1), _
Split(left(x, WorksheetFunction.Find(" ", x) - 1), "-")(0)), "dd/mm/yyyy")
Else
Debug.Print "Unusual string on the row " & i
End If
End If
Next i
End Sub
Private Function chkFind(strVal As String) As Boolean
On Error Resume Next
If WorksheetFunction.Find(" ", strVal) = 11 Then
chkFind = True
If Err.Number <> 0 Then
Err.Clear
On Error GoTo 0
chkFind = False
End If
Else
chkFind = False
End If
On Error GoTo 0
End Function
If first digits represents month, then the last two array (split) elements must be vice versa:
Split(left(x, WorksheetFunction.Find(" ", x) - 1), "-")(0), _
Split(left(x, WorksheetFunction.Find(" ", x) - 1), "-")(0))
instead of
Split(left(x, WorksheetFunction.Find(" ", x) - 1), "-")(1), _
Split(left(x, WorksheetFunction.Find(" ", x) - 1), "-")(1))
I need to find a string pattern of varying length and add a comma and space after that string pattern. For example, Search for the string "Cat. 123" I want to replace that string with the value "Cat. 123, " (i.e. add a comma and then a space at the end of "Cat. 123"). I am using Mac Office 2011 so any code has to work with the Mac version of Excel.
I've tried using Replace.Regex, Split and all other Replace functions I could find. The code below is the best I have come up with in order to do this but it's not adding the comma and the space to the end of the string pattern.
Sub test()
Dim r As Range, x, y
Set r = Cells.Find("?*, Cat. *", , , 1)
If Not r Is Nothing Then
Do
' Search for any string with the pattern Cat. 123, Cat. 14, etc
x = Split(r.Value, " Cat. ")
If x(UBound(x)) Like "* *" Then
' Replace string Cat. 123 with the new string Cat. 123,
y = Split(x(UBound(x)))
x(0) = "Cat. " & y(0) & ", " & x(0)
x(UBound(x)) = y(1)
Else
y = x(UBound(x))
x(0) = "Cat. " & y & ", " & x(0)
x(UBound(x)) = ""
End If
r.Value = Join(x)
Set r = Cells.FindNext(r)
Loop Until r Is Nothing
End If
End Sub
So the output of each cell that contains a pattern like the following examples: "Cat. 123" "Cat. 1" "Cat. 34" "Cat. 4567", would be changed to "Cat. 123, " "Cat. 1, " "Cat. 34, " "Cat. 4567, " NOTE: The original string will always have a period after the word "Cat" and will then be followed by a space and then followed with a single digit all the way up to four digits as shown above.
Give this a try (this time without vbscript dependent regex):
Sub tgr()
Dim aData As Variant
Dim sTemp As String
Dim lCatLoc As Long
Dim lNextSpace As Long
Dim i As Long, j As Long
With ActiveSheet.UsedRange
If .Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = .Value
Else
aData = .Value
End If
For i = 1 To UBound(aData, 1)
For j = 1 To UBound(aData, 2)
If Len(aData(i, j)) > 0 Then
If aData(i, j) Like "*Cat. [0-9]*" Then
lCatLoc = InStr(1, aData(i, j), "Cat. ", vbTextCompare)
lNextSpace = InStr(lCatLoc + 5, aData(i, j) & " ", " ", vbTextCompare)
sTemp = Mid(aData(i, j), lCatLoc, lNextSpace - lCatLoc)
If Right(sTemp, 1) <> "," Then aData(i, j) = Replace(aData(i, j), sTemp, sTemp & ", ")
End If
End If
Next j
Next i
.Value = aData
End With
End Sub
First off, I know there's a million questions about formatting dates, but I have not found a solution that works with my situation.
We are given a .csv file, and due to requirements, we must modify the file in a couple of ways.
Firstly, we run a VBA on the file in order to change the delimiter from "," to "|" (we have this working) using:
Const ForReading = 1
Const ForWriting = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("C:\Users\Z00393885\Desktop\csvStuff\"&myVar, ForReading)
count = 0
Do Until objFile.AtEndOfStream
strLine = objFile.ReadLine
strReplacer = Chr(34) & "," & Chr(34)
strLine = Replace(strLine, strReplacer, "|")
strLine = Replace(strLine, chr(34), "")
strNewText = strNewText & strLine & vbCrLF
count = count + 1
Loop
Print (count - 1)
objFile.Close
Set objFile = objFSO.OpenTextFile("C:\Users\Z00393885\Desktop\csvStuff\"&myVar, ForWriting)
objFile.WriteLine "BOF" & vbCrLF & now() & vbCrLF & (count - 1) & vbCrLF & strNewText & "EOF"
objFile.Close
The second requirement is the one that's giving me trouble, I have to look for every Date that is present (they are formatted: 11/8/2017 1:30 EST and lie within the 10th and 11th columns) and format the date so that it would be 11/08/2017 (we need to remove the Time as well as make sure that the day and month has a 0 if its only a single digit)
Is this doable within the Do Until loop? or would it be better to have a separate function to take care of that part. Either way, I am not even sure where to start with manipulating Dates within a file like this and not just a variable
EDIT: here is some of the .csv file
BOF
11/1/2017 12:08:21 PM
3
Course Code|Home Org|...|Release Date|Effective Date|...|Web Address
123|TAD Sites|...|10/31/2017 00:00:00 EDT|11/14/2017 00:00:00 EDT|...|http://URL
456|DAT Sites|...|11/5/2017 00:00:00 EDT|11/5/2017 00:00:00 EDT|...|http://URL
EOF
One thing you could do is split the original line into the columns, then you only need to consider the 10th and 11th columns:
Dim myArray() As String
'...
strLine = objFile.ReadLine
'Current delimiter is quote-comma-quote
strReplacer = Chr(34) & "," & Chr(34)
'Replace current delimiter with a pipe delimiter
strLine = Replace(strLine, strReplacer, "|")
'Remove any remaining quote marks
strLine = Replace(strLine, Chr(34), "")
'Split line using pipe delimiter
myArray = Split(strLine, "|")
'Convert column 10
myArray(9) = Format(CDate(Left(myArray(9), InStr(myArray(9), " ") - 1)), "mm/dd/yyyy")
'Convert column 11
myArray(10) = Format(CDate(Left(myArray(10), InStr(myArray(10), " ") - 1)), "mm/dd/yyyy")
'Join line back together with pipe delimiter
strLine = Join(myArray, "|")
'Create one huge string containing all lines in file
strNewText = strNewText & strLine & vbCrLF
'...
To use this as VBScript will require a few minor changes:
'Dim myArray() As String
Dim myArray
'...
strLine = objFile.ReadLine
'Current delimiter is quote-comma-quote
strReplacer = Chr(34) & "," & Chr(34)
'Replace current delimiter with a pipe delimiter
strLine = Replace(strLine, strReplacer, "|")
'Remove any remaining quote marks
strLine = Replace(strLine, Chr(34), "")
'Split line using pipe delimiter
myArray = Split(strLine, "|")
'Convert column 10
'myArray(9) = Format(CDate(Left(myArray(9), InStr(myArray(9), " ") - 1)), "mm/dd/yyyy")
myArray(9) = FormatDateTime(CDate(Left(myArray(9), InStr(myArray(9), " ") - 1)), 0)
'Convert column 11
'myArray(10) = Format(CDate(Left(myArray(10), InStr(myArray(10), " ") - 1)), "mm/dd/yyyy")
myArray(10) = FormatDateTime(CDate(Left(myArray(10), InStr(myArray(10), " ") - 1)), 0)
'Join line back together with pipe delimiter
strLine = Join(myArray, "|")
'Create one huge string containing all lines in file
strNewText = strNewText & strLine & vbCrLF
'...
I don't use VBScript myself, but I believe the FormatDateTime function will give you what you want as output. It seems to be locale-specific, but I assume you use mm/dd/yyyy format as standard in your location.
Have you thought about running a "text to column" function, simply altering the formats to the date columns, then outputting the file? This might be a lot easier than searching for characters and altering them the way you are doing.
With Range(pass the range here)
.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="|", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(..., ...),_
TrailingMinusNumbers:=True
Columns("x:x").NumberFormat = "mm/dd/yyyy"
From here you can save the file.
EDIT:
One caveat: you need to hard code the number of columns you will end up with into the array.
For example, if each row of the file contains 4 sections, you would use:
Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True
I got a macro that runs every 30 seconds using Application.Ontime. Every iteration creates a new csv file containing 8 columns and between 50 to 100 rows. The Application.Ontime normally runs from 8am to 5pm.
The problem is that sometimes during the day the macro just stop storing data in the csv files but still creates csv files. Hence, it still creates csv files but without any data in it.
EDIT:
The files that are created contain headers (StdTenorArray(0))
The variable StdXXXXXX is defined in another macro (button) and is a global variable
Here is the code:
Sub RunOnTime()
Application.CutCopyMode = False
Set ThisWkb = ThisWorkbook
dTime = Now + TimeSerial(0, 0, 30)
Application.OnTime dTime, "RunOnTime"
Call csvFileArray
Set ThisWkb = Nothing
End Sub
The above code calls this macro:
Sub csvFileArray()
Dim StdTenorArray(), ArkArr(5) As Variant
Dim FileName As String
Dim StdTenorCnt, h, j As Long
Set ThisWkb = ThisWorkbook
Application.CutCopyMode = False
ArkArr(1) = "XXXXXXctb"
ArkArr(2) = "XXXXXctb"
ArkArr(3) = "XXXXctb"
ArkArr(4) = "XXXctb"
ArkArr(5) = "XXctb"
ReDim StdTenorArray(ThisWkb.Sheets(ArkArr(1)).Range("B" & Rows.Count).End(xlUp).Row + ThisWkb.Sheets(ArkArr(2)).Range("B" & Rows.Count).End(xlUp).Row + ThisWkb.Sheets(ArkArr(3)).Range("B" & Rows.Count).End(xlUp).Row + ThisWkb.Sheets(ArkArr(4)).Range("B" & Rows.Count).End(xlUp).Row + ThisWkb.Sheets(ArkArr(5)).Range("B" & Rows.Count).End(xlUp).Row)
'Standard tenors
StdTenorCnt = 1
If StdXXXXXX = True Then
For j = 5 To 29
If UCase(ThisWkb.Sheets(ArkArr(1)).Cells(j, 4)) = True _
And WorksheetFunction.IsNumber(ThisWkb.Sheets(ArkArr(1)).Cells(j, 10)) = True _
And WorksheetFunction.IsNumber(ThisWkb.Sheets(ArkArr(1)).Cells(j, 11)) = True _
And IsDate(ThisWkb.Sheets(ArkArr(1)).Cells(j, 7)) = True _
And IsDate(ThisWkb.Sheets(ArkArr(1)).Cells(j, 8)) = True Then
StdTenorArray(StdTenorCnt) = "" & ThisWkb.Sheets(ArkArr(1)).Cells(j, 5) & ";" & Format(ThisWkb.Sheets(ArkArr(1)).Cells(j, 7), "yyyymmdd") & ";" & Format(ThisWkb.Sheets(ArkArr(1)).Cells(j, 8), "yyyymmdd") & ";" & ThisWkb.Sheets(ArkArr(1)).Cells(j, 9) & ";" & Replace(Format(ThisWkb.Sheets(ArkArr(1)).Cells(j, 10), "##0.00"), ",", ".") & ";" & Replace(Format(ThisWkb.Sheets(ArkArr(1)).Cells(j, 11), "##0.00"), ",", ".") & ";" & ThisWkb.Sheets(ArkArr(1)).Cells(j, 6) & ";JPD"
StdTenorCnt = StdTenorCnt + 1
End If
Next j
End I.
.
.
'more storing in the array like the part above
.
.
StdTenorArray(0) = "Symbol;SpotDate;ValueDate;Removed;Bid;Offer;Tenor;Channel"
Set fs = CreateObject("Scripting.FileSystemObject")
'test
app_path = ThisWkb.Path
Set a = fs.CreateTextFile("" & app_path & "\Test\" & Strings.Format(Now(), "dd.mm.yyyy") & " " & Strings.Format(Now(), "hh.mm.ss") & "." & Strings.Right(Strings.Format(Timer(), "#0.00"), 2) & ".csv", True)
For j = 0 To StdTenorCnt - 1
a.WriteLine ("" & StdTenorArray(j) & "")
Next j
a.Close
ThisWkb.Sheets("DKK").Cells(1, 27) = "" & Strings.Format(Now(), "hh:mm:ss") & ":" & Strings.Right(Strings.Format(Timer(), "#0.00"), 2) & ""
ReDim StdTenorArray(0)
Set fs = Nothing
Set a = Nothing
Set ThisWkb = Nothing
Application.CutCopyMode = False
End Sub
Hope someone have a solution to this problem or maybe can point me in the right direction.
Have a nice weekend.
\Kristian