I have written txt-files with excel and a macro in the past several times. I didn't hit 10000 lines or more. Never say Never...
My .csv file has over 87000 rows like that example "15k50,CityABC,56ab,CountryofCity,ID,Street". I use the Split() function in order to separate the values. The Macro formated and wrote the values as single lines to the txt file.
Around 9800 lines the txt-file closed... But why? I tried with Slepp() to make sure the print algho isn't overloaded or something else.
The counter 10000 is there because I want to make it easer to understand for you. If it goes over 10000 the problem is "solved".
Information txt-File format:
ASCII
Unix (LF)
Shortcut, after several comments
with Minimal, Reproducible Example overworked the code (deleted sleep, simplification variable names, try to make code from scratch)
changed SplitString() to Split(), because call over function is stupid...
after printed line 9000 to the txt-file the following error popup "Run-Time Error 5: Invalid Procedure Call or Argument" at code line fso.WriteLine ("# " & strArr(0) & " # " & strArr(1) & ...
Option Explicit
#If VBA7 Then
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If
Sub formattedToTxt()
Dim strArr() As String
Dim strB As String
Dim intC As Integer
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
strB = filePathExport & "\" & filenameExport & fileFormatExport
Set fso = fso.CreateTextFile(strB, True)
Do While counter <= 10000
strArr = Split(ActiveCell.Value, ",")
intC = CalcWhitespace(strArr(5), 40)
fso.WriteLine ("# " & strArr(0) & " # " & strArr(1) & " # " & strArr(2) & " # " & strArr(3) & " # " & strArr(4) & " # " & strArr(5) & Space(intC) & "#")
ActiveCell.Offset(1, 0).Select
If ((counter Mod 1000) = 0) Then
Debug.Print ("Entry " & counter & " written")
End If
counter = counter + 1
Loop
End Sub
Function CalcWhitespace(rawStr As String, maxLen As Integer) As Integer
CalcWhitespace = maxLen - Len(rawStr)
End Function
Any Idea?
Thanks to all helpful VBA people from the comments above. I cleaned up the code. The following snipped is the full solution.
The .csv table contains diffrent strings with diffrent length in each line.
In the final solution the whitespaces are checked before. It is importend to know the max-Length strings at the data. To format the txt-file output readable.
Maybe, an other solution has a better performance, but that works well in my case.
Have a great day!
'Find max string length for each whitespace
counter = 0
ActiveSheet.Cells(2, 1).Select 'ignore Headlinedata, because diffrent format in compare to data
intC = (UBound(arrWhitespace) - LBound(arrWhitespace))
Do While ActiveCell.Value <> ""
strArr = Split(ActiveCell.Value, ",")
For counterTwo = 0 To intC
If Len(strArr(counterTwo)) > arrWhitespace(counterTwo) Then arrWhitespace(counterTwo) = Len(strTempArr(counterTwo))
Next counterTwo
counter = counter + 1
ActiveCell.Offset(1, 0).Select
If ((counter Mod 1000) = 0) Then
Debug.Print ("Entry " & counter & " checked")
End If
Loop
'Print Body of txt-file
Do While ActiveCell.Value <> ""
strArr = Split(ActiveCell.Value, ",")
'build string for each line
strB = ""
strB = strB & "# " & strArr(0) & " #"
intC = CalcWhitespace(strArr(1), arrWhitespace(1))
strB = strB & " " & strArr(1) & Space(intC) & " #"
intC = CalcWhitespace(strArr(2), arrWhitespace(2))
strB = strB & " " & strArr(2) & Space(intC) & " #"
intC = CalcWhitespace(strArr(3), arrWhitespace(3))
strB = strB & " " & strArr(3) & Space(intC) & " #"
intC = CalcWhitespace(strArr(4), arrWhitespace(4))
strB = strB & " " & strArr(4) & Space(intC) & " #"
intC = CalcWhitespace(strArr(5), arrWhitespace(5))
strB = strB & " " & strArr(5) & Space(intC) & " #"
fso.WriteLine (strB)
ActiveCell.Offset(1, 0).Select
If ((counter Mod 1000) = 0) Then
Debug.Print ("Entry " & counter & " written")
End If
counter = counter + 1
Loop
Function CalcWhitespace(rawStr As String, maxLen As Integer) As Integer
CalcWhitespace = maxLen - Len(rawStr)
End Function
Next time I will use minimal-reproducible-example to avoid .Select
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 need to obtain 2 random cases for each complaint handler in a data table that can be used for sampling.
Assuming I would have to group the data using the Handler ID (unique reference for each complaint handler) and then some how select two random pieces of information from the groups.
I have grouped this information using a Pivot. All case handlers in this has 2 or less cases so no further action needs to be taken on these. However, there is an exception with Chris Smith (h238) as he has three cases and the max sampling is 2 per case handler.
I need a script that will select two random cases for Chris and remove any additional cases (so we have a random sample of 2 cases).
I can do this manually by going filtering table by Chris' cases and then removing cases until there is only two remaining. However, the actual data set would be much larger so would be very time consuming and this process needs to be ran several times a day with the data in the table continually changing.
That's an interesting one!
Here is my solution. I've tried several possible versions.
Try 1:
As per originally posted data - Chris Smith (h238) is overloaded with 1 task and there are enough people to reassign tasks:
Try 2:
Chris Smith (h238) is still overloaded, but this time with 3 tasks and there are enough people to reassign tasks:
Try 3:
Poor Chris Smith (h238) is totally overloaded, but this time there are not enough people to reassign tasks:
Try 4:
This time Jane Doe (h324) is in line with Chris Smith (h238) - they are overloaded, but there are not enough people to reassign tasks:
Cases where there are no overloaded or no free people are breaking with appropriate messages, didn't do screenshot.
The code:
Sub ReassignCases()
' Variables
' people related:
Dim handlerIdRange As Range, handlerId As Range
Dim maxCases As Long
Dim cases As Long
Dim name As String, id As String
Dim nameTo As String, idTo As String
Dim caseRef As Range
' arrays:
Dim overloaded() As String
Dim free() As String
' counters:
Dim o As Long, f As Long, i As Long, c As Long, j As Long
' unique values container
Dim handlersList As New Collection
' output
Dim msg As String
Dim workSht As Worksheet
'----------------------------------------------------
' reassign the sheet name as you have in your workbook
Set workSht = ThisWorkbook.Sheets("Sheet1")
' parameter that can be changed if needed
maxCases = 2
With workSht
Set handlerIdRange = Range(.Cells(2, 2), .Cells(Rows.Count, 2).End(xlUp))
End With
' get the list of handlers
On Error Resume Next
For Each handlerId In handlerIdRange
handlersList.Add handlerId & ";" & handlerId.Offset(0, -1), handlerId & ";" & handlerId.Offset(0, -1)
Next
Err.Clear
On Error GoTo 0
For i = 1 To handlersList.Count
' look for overloaded
If Application.WorksheetFunction.CountIf(handlerIdRange, Split(handlersList(i), ";")(0)) > maxCases Then
ReDim Preserve overloaded(o)
' adding to array: id;name;qty of cases
overloaded(o) = handlersList.Item(i) & ";" & Application.WorksheetFunction.CountIf(handlerIdRange, Split(handlersList(i), ";")(0))
o = o + 1
' look for those who has less the 2 cases. If one has 2 cases - he is not free
ElseIf Application.WorksheetFunction.CountIf(handlerIdRange, Split(handlersList(i), ";")(0)) < maxCases Then
ReDim Preserve free(f)
free(f) = handlersList.Item(i)
f = f + 1
End If
Next
' check whether there are overloaded handlers
If Not Not overloaded Then
' if yes - proceed further
Else
' if not - inform and quit
MsgBox "There are no overloaded handlers.", vbInformation, "Info"
Exit Sub
End If
' check whether there are free handlers
If Not Not free Then
' if yes - proceed further
Else
' if not - inform and quit
o = UBound(overloaded) + 1
MsgBox "There " & IIf(o = 1, "is ", "are ") & o & " overloaded " & IIf(o = 1, "handler", "handlers") & ", but 0 free.", vbInformation, "Info"
Exit Sub
End If
msg = ""
' go through array of overloaded
For i = LBound(overloaded) To UBound(overloaded)
' Id of overloaded
id = Split(overloaded(i), ";")(0)
' Name of overloaded
name = Split(overloaded(i), ";")(1)
' number of over cases = total assigned - 2 (max cases)
cases = Split(overloaded(i), ";")(2) - maxCases
'
' check that there some free people left
If Not c > UBound(free) Then
' go through each handler in the array of free people
' free people are those, who have only 1 task and can take another 1
' if c was not used yet it is 0, otherwise, it will continue looping through free people
For c = c To UBound(free)
idTo = Split(free(c), ";")(0)
nameTo = Split(free(c), ";")(1)
' find the first match of the id in Id range
Set caseRef = handlerIdRange.Find(what:=id, LookIn:=xlValues)
' give an outcome of what was reassigned
msg = msg & "Task: " & caseRef.Offset(0, 1).Text & " was reassigned from " & name & " (" & id & ") "
With caseRef
.Value = idTo
.Offset(0, -1).Value = nameTo
End With
msg = msg & "to " & nameTo & " (" & idTo & ")" & Chr(10)
cases = cases - 1
' when all needed cases are passed to other stop looking through free people
If cases = 0 Then Exit For
Next
' if the loop through free people is finished,
' but there left some more - go to warning creation
If Not cases = 0 Then GoTo leftCases
Else
leftCases:
msg = msg & Chr(10) & Chr(10) & "There are no more free handlers." & Chr(10)
For j = i To UBound(overloaded)
msg = msg & Split(overloaded(j), ";")(1) & " is still overloaded with " & cases & " cases." & Chr(10)
Next
msg = msg & Chr(10) & "Operation completed with warnings." & Chr(10)
msg = msg & Chr(10) & "Would you like to save results?"
If MsgBox(msg, vbExclamation + vbYesNo, "Done") = vbYes Then SaveResults (msg)
Exit Sub
End If
Next
msg = msg & Chr(10) & "Operation completed." & Chr(10)
msg = msg & Chr(10) & "Would you like to save results?"
If MsgBox(msg, vbInformation + vbYesNo, "Done") = vbYes Then SaveResults (msg)
End Sub
Sub SaveResults(Text As String)
Dim lines() As String, temp() As String
Dim i As Long, j As Long
Dim FileName As String
lines = Split(Text, Chr(10))
For i = LBound(lines) To UBound(lines)
If lines(i) Like "Task:*" Then
ReDim Preserve temp(j)
temp(j) = lines(i)
j = j + 1
End If
Next
Dim fi As Long
FileName = "Task reassignment log"
FileName = Application.GetSaveAsFilename(InitialFileName:=FileName, FileFilter:="Text Files (*.txt), *.txt", Title:="Saving as text...")
If UCase(FileName) = "FALSE" Then Exit Sub
If CheckFileExists(FileName) Then
If MsgBox("The file " & Dir(FileName) & " already exists. Overwrite?", vbQuestion + vbYesNo) = vbYes Then
WriteToFile FileName, temp
Else
i = 0
Do Until Not CheckFileExists(FileName)
For j = Len(FileName) To 1 Step -1
If Mid(FileName, j, 1) = Application.PathSeparator Then Exit For
Next
FileName = Left(FileName, j)
If i = 0 Then
FileName = FileName & "Task reassignment log.txt"
Else
FileName = FileName & "Task reassignment log (" & i & ")" & ".txt"
End If
i = i + 1
Loop
WriteToFile FileName, temp
MsgBox "The file was saved with " & Chr(34) & Dir(FileName) & Chr(34) & " name", vbInformation
End If
Else
WriteToFile FileName, temp
End If
End Sub
Sub WriteToFile(FileName As String, Text() As String)
Dim i As Long
Open FileName For Output As #1
For i = LBound(Text) To UBound(Text)
Write #1, Text(i)
Next
Close #1
End Sub
Function CheckFileExists(FileName As String) As Boolean
CheckFileExists = False
If Not Dir(FileName) = "" Then CheckFileExists = True
End Function
Note
1. I didn't randomize a list of free people, so they are taken one by one. If you do need this - you can easily find a macro to randomize an array and insert it as side function.
2. I'm not sure that it works perfectly - comments are appreciated!
Update
I've slept on this question and decided to complete my answer with such an essential thing as saving the reassignment log to text file, so the code is updated.
in a VBA excel macro I am using, I have the following code:
For k = MinDeg To MaxDeg
OutputStr = Trim(OutputStr & "a" & Str(k) & " = " & _
Str(MyCoe) & " ± " & _
Str(MyErr) & Chr(10))
Next k
Where "MyCoe" and "MyErr" are given numbers, and "minDeg" and "MaxDeg" are integers.
My question is:
How can I make "Str(k)" appear in the outputstr as subscript text?
If Unicode is available in your environment, another option would be to use the subscripted Unicode characters for Str(K). Making some modifications to Gary's Student code so as to get output in A1:
Option Explicit
Sub foo()
Dim K As Long
Const MinDeg As Long = 10
Const MaxDeg As Long = 13
Dim sK As String, I As Long
Const MyCoe As Long = 3
Const MyErr As Long = 5
Dim OutPutStr As String
For K = MinDeg To MaxDeg
sK = ""
For I = 1 To Len(CStr(K))
sK = sK & ChrW(832 & Mid(CStr(K), I, 1))
Next I
OutPutStr = Trim(OutPutStr & "a" & sK & " = " & _
Str(MyCoe) & " ± " & _
Str(MyErr) & Chr(10))
Next K
Cells(1, 1) = OutPutStr
End Sub
Note that the subscripted values also appear in the formula bar.
First I run this simple mod to your code:
Sub WhatEverr()
mindeg = 10
maxdeg = 13
mycoe = 3
myerr = 5
For k = mindeg To maxdeg
outputstr = Trim(outputstr & "a" & Str(k) & " = " & _
Str(mycoe) & " ± " & _
Str(myerr) & Chr(10))
Next k
Range("A1").Value = outputstr
End Sub
to get this in A1:
Then I run:
Sub formatcell()
Dim i As Long, L As Long, rng As Range
Dim s As String
Set rng = Range("A1")
s = rng.Value
L = Len(s)
For i = 1 To L
ch = Mid(s, i, 1)
If ch = "a" Then
rng.Characters(Start:=i + 2, Length:=2).Font.Subscript = True
End If
Next i
End Sub
To apply the format:
In Excel, this type of character formatting is a property of the Range object. You do not build it into the string like you would in HTML.
I am running into an issue that is driving me crazy. I have two FOR loops in my macro that each have a counter to keep track of how many times a certain process was performed. The counters work great and at the end of the loop contain the correct numbers. The next thing I have to do is to format the counts into a five digit number with leading zeros. I have tried this using two different approaches (see below).
cCount = String(5 - Len(cTemp), "0") & cTemp
mCount = String(5 - Len(mTemp), "0") & mTemp
or
cCount = Format(cTemp, "00000")
mCount = Format(mTemp, "00000")
The problem is with the second counter. As I step through it, the first format formula works, but the second line does not, regardless of which version above that I use. Now here is the thing, if, while I am still in the macro, I go and change the name of mCount to anything else, for example mCnt, and then move the macro step back up to reprocess that line, it will correctly format the variable. But it isn't the name, because if I then run the macro again using mCnt, it will do the same thing. I can change it back to mCount and it will work.
All variables are dimmed as Integers. An example of what I am looking for would be if mTemp is 15, then mCount would be 00015. However, mCount is just coming back as 15. cCount is working fine.
The fact that everything is correct and that I can make it work if I pause the macro, change the variable name, and reprocess the line, has got me completely at a loss as to what the issue is.
Sub MakePay()
Dim strFileToOpen As String
Dim payDate, payTab, payCheckTemp, payCheck, payAccTemp As String
Dim payAcc, payAmount, payTotalC, payTotalM As String
Dim savePath As String
Dim payFileNameCLP, payFileNameMF As String
Dim payString1, payString2, payString3, payString4, payString5, payString6 As String
Dim payString7, payString8, payString9 As String
Dim rCnt, i, j, cTemp, cCount, mTemp, mCount As Integer
Dim payTotalMTemp, payAmountTemp, payTotalCTemp As Double
' Set date
payDate = Format(Now(), "yyyymmddhhmmss")
' Ask for check number and format to field length
payCheckTemp = InputBox("Please enter the check number.")
payCheck = payCheckTemp & String(15 - Len(payCheckTemp), " ")
' Create file names and open text files for writing
payFileNameCLP = "CLP_" & payDate & "_01.txt"
payFileNameMF = "MDF_" & payDate & "_01.txt"
savePath = Environ("USERPROFILE") & "\Desktop\"
Open savePath & payFileNameCLP For Output As #1
Open savePath & payFileNameMF For Output As #2
' Build header rows and print them
payString1 = "100"
payString2 = "200 C"
Print #1, payString1
Print #1, payString2
Print #2, payString1
Print #2, payString2
' reset counters for number of claims and total dollar amounts in files
cTemp = 0
mTemp = 0
payTotalCTemp = 0
payTotalMTemp = 0
For i = 1 To Sheets.Count
' Process the Clearpoint tab
If Left(Sheets(i).Name, 3) = "CLE" Then
Sheets(i).Activate
rCnt = Cells(Rows.Count, 1).End(xlUp).Row
For j = 3 To (rCnt - 1)
' Read accession # and format it for field length
payAccTemp = Cells(j, 3).Value
payAcc = payAccTemp & String(17 - Len(payAccTemp), " ")
' Read payment amount, if $0, skip
payAmountTemp = Format(Cells(j, 5).Value2, "#,###.00")
If payAmountTemp = "" Then
GoTo SkipCDL
End If
' Add payment to total Clearpoint payments
payTotalCTemp = payTotalCTemp + payAmountTemp
' Format payment by deleting decimal and then format to field length
payAmount = Format(payAmountTemp * 100, "0000000;-000000")
' Build payment strings and print them
payString3 = "400" & String(10, " ") & payAcc & payCheck
payString4 = "450" & String(10, " ") & payAcc & String(150, " ") & payAmount
payString5 = "500" & String(10, " ") & payAcc & String(73, " ") & payAmount
Print #1, payString3
Print #1, payString4
Print #1, payString5
' Increase Clearpoint patient count
cTemp = cTemp + 1
SkipCDL:
Next j
' Process Medfusion tab
ElseIf Left(Sheets(i).Name, 3) = "MED" Then
Sheets(i).Activate
rCnt = Cells(Rows.Count, 1).End(xlUp).Row
For j = 3 To (rCnt - 1)
' Read accession # and format it for field length
payAccTemp = Cells(j, 3).Value
payAcc = payAccTemp & String(17 - Len(payAccTemp), " ")
' Read payment amount, if $0, skip
payAmountTemp = Format(Cells(j, 5).Value2, "#,###.00")
If payAmountTemp = "" Then
GoTo SkipMDF
End If
' Add payment to total Medfusion payments
payTotalMTemp = payTotalMTemp + payAmountTemp
' Format payment by deleting decimal and then format to field length
payAmount = Format(payAmountTemp * 100, "0000000;-000000")
' Build payment strings and print them
payString3 = "400" & String(10, " ") & payAcc & payCheck
payString4 = "450" & String(10, " ") & payAcc & String(150, " ") & payAmount
payString5 = "500" & String(10, " ") & payAcc & String(73, " ") & payAmount
Print #2, payString3
Print #2, payString4
Print #2, payString5
' Increase Medfusion count
mTemp = mTemp + 1
SkipMDF:
Next j
End If
Next i
' Format patient counter and total payment to field length
cCount = Format(cTemp, "00000")
mCount = Format(mTemp, "00000")
payTotalC = Format(payTotalCTemp * 100, "000000000;-00000000")
payTotalM = Format(payTotalMTemp * 100, "000000000;-00000000")
' Build footer strings and print them
payString6 = "800" & String(26, " ") & "9999" & cCount & String(131, " ") & payTotalC
payString7 = "800" & String(26, " ") & "9999" & mCount & String(131, " ") & payTotalM
payString8 = "900" & String(57, " ") & "099990" & cCount & String(154, " ") & String(2, "0") & payTotalC
payString9 = "900" & String(57, " ") & "099990" & mCount & String(154, " ") & String(2, "0") & payTotalM
Print #1, payString6
Print #2, payString7
Print #1, payString8
Print #2, payString9
' Close all files
Application.DisplayAlerts = False
Close #1
Close #2
Application.DisplayAlerts = True
End Sub
The issue is with how the variables are declared.
In VBA/classic vb, all declarations should be on their own line OR have the correct data type specified, otherwise you risk accidentally creating a Variant data type, which can masquerade as any other data type, which the VB engine has rules for determining the type.
See https://msdn.microsoft.com/en-us/library/56ht941f(v=vs.90).aspx
Also, whenever coding in VBA make sure Option Explicit is declared at the top of any new code module. It will save you loads of pain in the future.
Also, you are trying to push String formatting into an Integer, which cannot happen.
So...
Option Explicit
.....
'Dim i, j as Integer 'BAD i is a variant, j is an integer
Dim i As Integer
Dim j As Integer 'GOOD both are Integers
'OR
Dim x As Integer, y as Integer 'I believe this will work too
dim displayI as String
i = 23
displayI = Format(i, "00000")
In your code why not just format inline?
payString6 = "800" & String(26, " ") & "9999" & Format(cCount,"00000") & String(131, " ") & payTotalC
So I have built a workbook for validation and publishing sets of other workbooks/reports out to another location. Part of the process is for the user to enter a date value into a cell, and that is checked for within the reports the user has listed.
Date formatting doesn't matter because I am doing a date type to date type comparison in my validation function.
Basically:
if CDate(UserVal) = CDate(ValFromString) then
'do stuff
end if
The other common occurrence is the date has always been at the end of the string in the compared cell.
Example:
Current 52 Weeks Ending 04/10/15
Cur 52 Weeks Apr 4, 2015
Current 52 WE 4-Apr-15
No matter what format the user inputs into the validation cell, I just keep stripping from the right until isdate pops true.
I know I have been lucky in this setup, with the date always being at the end. I've now run into two instances that do not work.
CURRENT 12 WEEKS (4 WEEKS ENDING 04/11/15)
4 WE 04/11/2015 Current 12
In the first, the parenthesis breaks my right() stripping. In the second, the date is in the middle. The format of the date value differs from report to report, so I cannot do a instr(1, String, cstr(UserVal)) to accomplish the check. The location of the date is not set in stone either, as it could be at the end, beginning, or anywhere in the middle of the string.
Short way of putting it, is there an easy way to scan a string for a specified date value, agnostic of format?
Here is my feeble attempt :D
This will match a wide range of date formats
Hope this helps
Sub Sample()
Dim MyAr(1 To 5) As String, frmt As String
Dim FrmtAr, Ret
Dim i As Long, j As Long
MyAr(1) = "(This 01 has 04/10/15 in it)"
MyAr(2) = "This 04/10/2015"
MyAr(3) = "4-Apr-15 is a Sample date"
MyAr(4) = "(Apr 4, 2015) is another sample date"
MyAr(5) = "How about ((Feb 24 2012)) this?"
'~~> Various date formats
'~~> YYYY (/????) grouped together. Will search for this first
frmt = "??/??/????|?/??/????|??/?/????|??-??-????|"
frmt = frmt & "?-??-????|??-?-????|??? ?? ????|??? ? ????|"
frmt = frmt & "?-???-????|???-??-????|???-?-????|"
frmt = frmt & "??? ??, ????|??? ?, ????|"
'~~> YY (??) grouped after. Will search for this later
frmt = frmt & "??-???-??|?-???-??|??/??/??|?/??/??|??/?/??|"
frmt = frmt & "??-??-??|?-??-??|??-?-??|???-??-??|???-?-??|"
frmt = frmt & "|??? ?? ??|??? ? ??|??? ??, ??|??? ?, ??|"
FrmtAr = Split(frmt, "|")
For i = LBound(MyAr) To UBound(MyAr)
For j = 0 To UBound(FrmtAr)
'Something like =MID(A1,SEARCH("??/??/??",A1,1),8)
Expr = "=MID(" & Chr(34) & MyAr(i) & Chr(34) & ",SEARCH(" & _
Chr(34) & Trim(FrmtAr(j)) & Chr(34) & _
"," & Chr(34) & MyAr(i) & Chr(34) & ",1)," _
& Len(Trim(FrmtAr(j))) & ")"
Ret = Application.Evaluate(Expr)
If Not IsError(Ret) Then
If IsDate(Ret) Then
Debug.Print Ret
Exit For
End If
End If
Next j
Next i
End Sub
Output
EDIT
You can also use this as an Excel function
Paste this in a module
Public Function ExtractDate(rng As Range) As String
Dim frmt As String
Dim FrmtAr, Ret
Dim j As Long
ExtractDate = "No Date Found"
'~~> Various date formats
'~~> YYYY (/????) grouped together. Will search for this first
frmt = "??/??/????|?/??/????|??/?/????|??-??-????|"
frmt = frmt & "?-??-????|??-?-????|??? ?? ????|??? ? ????|"
frmt = frmt & "?-???-????|???-??-????|???-?-????|"
frmt = frmt & "??? ??, ????|??? ?, ????|"
'~~> YY (??) grouped after. Will search for this later
frmt = frmt & "??-???-??|?-???-??|??/??/??|?/??/??|??/?/??|"
frmt = frmt & "??-??-??|?-??-??|??-?-??|???-??-??|???-?-??|"
frmt = frmt & "|??? ?? ??|??? ? ??|??? ??, ??|??? ?, ??|"
FrmtAr = Split(frmt, "|")
For j = 0 To UBound(FrmtAr)
'Something like =MID(A1,SEARCH("??/??/??",A1,1),8)
Expr = "=MID(" & Chr(34) & rng.Value & Chr(34) & ",SEARCH(" & _
Chr(34) & Trim(FrmtAr(j)) & Chr(34) & _
"," & Chr(34) & rng.Value & Chr(34) & ",1)," _
& Len(Trim(FrmtAr(j))) & ")"
Ret = Application.Evaluate(Expr)
If Not IsError(Ret) Then
If IsDate(Ret) Then
ExtractDate = Ret
Exit For
End If
End If
Next j
End Function
Note: I am still working on a RegEx version which will be pretty much shorter than this...
Edit: As promised! I am sure it make me made more perfect but now I can't spend more time on this :)
RegEx Version
Sub Sample()
Dim MyAr(1 To 5) As String
MyAr(1) = "(This 01 has (04/10/15) in it)"
MyAr(2) = "This 04/10/2015"
MyAr(3) = "4-Apr-15 is a smaple date"
MyAr(4) = "(Apr 4, 2015) is another sample date"
MyAr(5) = "How about ((Feb 24 2012)) this?"
For i = 1 To 5
Debug.Print DateExtract(MyAr(i))
Next i
End Sub
Function DateExtract(s As String) As String
Dim a As String, b As String, c As String
Dim sPattern As String
sPattern = "\b(jan|feb|mar|apr|may|jun|jul|aug|sep|oct|nov|dec)"
sPattern = sPattern & "\s(\d\d?),?\s+(\d{2,4})|(\d\d?)[\s-]("
sPattern = sPattern & "jan|feb|mar|apr|may|jun|jul|aug|sep|oct|nov|dec"
sPattern = sPattern & ")[\s-,]\s?(\d{2,4})|(\d\d?)[-/](\d\d?)[-/](\d{2,4})\b"
With CreateObject("VBScript.RegExp")
.Global = False
.IgnoreCase = True
.Pattern = sPattern
If .Test(s) Then
Dim matches
Set matches = .Execute(s)
With matches(0)
a = .SubMatches(0) & .SubMatches(3) & .SubMatches(6)
b = .SubMatches(1) & .SubMatches(4) & .SubMatches(7)
c = .SubMatches(2) & .SubMatches(5) & .SubMatches(8)
DateExtract = a & " " & b & " " & c
End With
End If
End With
End Function
The following will find a date if it is there, but it may not be the date you want:
Sub INeedADate()
Dim st As String, L As Long, i As Long, j As Long
st = ActiveCell.Text
L = Len(st)
For i = 1 To L - 1
For j = 1 To L
st2 = Mid(st, i, j)
If IsDate(st2) Then
MsgBox CDate(st2)
Exit Sub
End If
Next j
Next i
End Sub
The routine generates all properly sequenced sub-strings of a string and tests each one for IsDate()
The problem is that for:
Current 52 Weeks Ending 04/10/15
It finds the sub-string:
04/1
first - which is a valid date!!
Do you want ALL valid dates within the string ???
EDIT#1:
The solution is to just run the length part of the Mid() function backwards:
Sub INeedADate()
Dim st As String, L As Long, i As Long, j As Long
st = ActiveCell.Text
L = Len(st)
For i = 1 To L - 1
For j = L To 1 Step -1
st2 = Mid(st, i, j)
If IsDate(st2) Then
MsgBox CDate(st2)
Exit Sub
End If
Next j
Next i
End Sub