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
Related
I am very confused on where I am at right now. But I need to parse/separate out the first, middle, and last name of a input function. Then display the number of characters that is in that entire name minus the spaces as well as display the number of characters in users first and last names minus the spaces.
ex: Matt Lose Wright has 15 Characters
Matt Wright has 10 Characters
I am trying
My Code:
Sub ParseName()
Dim name As String
name = InputBox("Enter First Name, Middle Name, and Last Name")
Dim First As Double
Dim Middle As Double
Dim Last As Double
First = InStr(1, name, "First", vbTextCompare)
Middle = InStr(2, name, "Middle", vbTextCompare)
Last = InStr(3, name, "Last", vbTextCompare)
Dim Count As Integer
Dim Cell As Object
Dim n As Integer
Count = 0
name = InputBox("Enter First Name, Middle Name, and Last Name")
If name = "" Then
For Each Cell In Selection
n = InStr(1, Cell.Value, name)
While n <> 0
Count = Count + 1
n = InStr(n + 1, Cell.Value, name)
Wend
Next Cell
MsgBox Count & " Occurrences of " & name
End If
End Sub
To summarise - I have shown you three techniques.
A = "Matt Lose Wright"
B = Split(A, " ")
MsgBox Len(Replace(A, " ", ""))
For Each name in B
MsgBox Name & " " & Len(Name)
Next
MsgBox B(0) & " " & B(UBound(B)) & " " & Len(B(0)) & " " & Len(B(UBound(B)))
Output
14
Matt 4
Lose 4
Wright 6
Matt Wright 4 6
See Split, your friend when parsing - https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/split-function
A = "Matt Lose Win Wright"
B = Split(A, " ")
MsgBox Len(Replace(A, " ", ""))
For Each name in B
MsgBox Name & " " & Len(Name)
Next
MsgBox B(0) & " " & B(UBound(B)) & " " & Len(B(0)) & " " & Len(B(UBound(B)))
Output
17
Matt 4
Lose 4
Win 3
Wright 6
Matt Wright 4 6
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 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
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.
Below code is counting a final amount of students in a school and average amount of students in a class.
It's running the code until the user types "0".
How can I ensure that the "0 class" won't be counted as an additional class? Currently I am achieving it by subtracting -1 from B, but it's not an elegant solution - calculation is correct, but the class is still listed in final MsgBox.
Btw, if I wanted to end the loop when user is leaving the cell empty, what should I do? Simple Loop Until Zak = "" doesn't work.
Many thanks,
Sub D1()
Dim Zak As Byte
Dim B As Byte, C As Byte
Dim kzak As String
Dim ktrid
Dim trid As Byte
Dim k, l As Integer
B = 0
kzak = ""
Do
Zak = InputBox("Amount of students")
B = B + 1
kzak = kzak & Str(B) & (" class") & (" ") & _
("Students ") & Str(Zak) & Chr(10)
k = k + Zak
Loop Until Zak = 0
C = (B - 1)
l = k / C
MsgBox kzak & Chr(10) & ("At school is ") & Str(k) & (" students") & _
(", on avarage ") & Str(l) & (" in a class")
End Sub
This is a late post, but here is code to accomplish all the requirements you stated with just a few tweaks to your existing code:
Public Sub D2()
Dim Zak As String
Dim B As Integer
Dim kzak As String
Dim k As Integer
Dim l As Integer
B = 0
kzak = ""
Do
Zak = InputBox("Amount of students")
If Val(Zak) > 0 Then
B = B + 1
kzak = kzak & Str(B) & (" class") & (" ") & ("Students ") & Zak & Chr(10)
k = k + Val(Zak)
End If
Loop Until Zak = ""
If B > 0 Then
l = k / B
MsgBox kzak & Chr(10) & ("At school is ") & Str(k) & (" students") & (", on avarage ") & Str(l) & (" in a class")
End If
End Sub
Notice some of the changes I made.
First, I declared the variables more appropriately. Also, with your code k would have been a variant.
Second, I was able to remove the B - 1 hack while also assuring `B' had a value to avoid a divide by zero error.
Third, this code handles Cancel from the InputBox.
A common approach to this is to ask first, and then test with a Do While instead of a Loop Until, and then ask again. Something like this:
Zak = InputBox("Amount of students")
Do While Zak <> 0
...
...
Zak = InputBox("Amount of students")
Loop