I am given N lists of M items that will be physically realized (someone actually has to put items (names abbreviated here,) in physical bins.) Then the bins are emptied, if necessary, and re-used, working left-to-right. There is a real cost to putting a different item in a bin than what was in it before. I rearrange the lists to minimize changes, manually. Software can do it faster, and more reliably in an optimum way. The whole thing happens in Excel (then paper, then in a factory.) I wrote some VBA, a brute-force affair, that did really well with some examples. But not all. If I knew the family of optimization that this is, I could code it, even if I just pass something to a DLL. But multiple searches online have not succeeded. I tried several phrasings. It's not a traveling S.., knapsack, etc. It seems similar to the Sequence Alignment problem from Bioinformatics. Someone recognize it? Let's hear it, Operations Research people.
As it turns out, the naive solution just needed tweaking. Look at a cell. Try to find the same letter in the column to it's right. If you find one, swap it with whatever it to the right of that cell now. Work your way down. The ColumnsPer parameter accounts for the real-world use, where each column has an associated list of numbers and the grid columns alternate labels, numbers, labels, ...
Option Explicit
Public Const Row1 As Long = 4
Public Const ColumnsPer As Long = 1 '2, when RM, %
Public Const BinCount As Long = 6
Public Const ColCount As Long = 6
Private Sub reorder_items_max_left_to_right_repeats(wksht As Worksheet, _
col1 As Long, maxBins As Long, maxRecipes As Long, ByVal direction As Integer)
Dim here As Range
Set here = wksht.Cells(Row1, col1)
here.Activate
Dim cond
For cond = 1 To maxRecipes - 1
Do While WithinTheBox(here, col1, direction)
If Not Adjacent(here, ColumnsPer).Value = here.Value Then
Dim there As Range
Set there = Matching_R_ange(here, direction)
If Not there Is Nothing Then swapThem Adjacent(here, ColumnsPer), there
End If
NextItemDown:
Set here = here.Offset(direction, 0)
here.Activate
'Debug.Assert here.Address <> "$AZ$6"
DoEvents
Loop
NextCond:
Select Case direction
Case 1
Set here = Cells(Row1, here.Column + ColumnsPer)
Case -1
Set here = Cells(Row1 + maxBins - 1, here.Column + ColumnsPer)
End Select
here.Activate
Next cond
End Sub
Function Adjacent(fromHereOnLeft As Range, colsRight As Long) As Range
Set Adjacent = fromHereOnLeft.Offset(0, colsRight)
End Function
Function Matching_R_ange(fromHereOnLeft As Range, _
ByVal direction As Integer) As Range
Dim rowStart As Long
rowStart = Row1
Dim colLook As Long
colLook = fromHereOnLeft.Offset(0, ColumnsPer).Column
Dim c As Range
Set c = Cells(rowStart, colLook)
Dim col1 As Long
col1 = c.Column
Do While WithinTheBox(c, col1, direction)
Debug.Print "C " & c.Address
If c.Value = fromHereOnLeft.Value _
And c.Row <> fromHereOnLeft.Row Then
Set Matching_R_ange = c
Exit Function
Else
Set c = c.Offset(1 * direction, 0)
End If
DoEvents
Loop
'returning NOTHING is expected, often
End Function
Function WithinTheBox(ByVal c As Range, ByVal col1 As Long, ByVal direction As Integer)
Select Case direction
Case 1
WithinTheBox = c.Row <= Row1 + BinCount - 1 And c.Row >= Row1
Case -1
WithinTheBox = c.Row <= Row1 + BinCount - 1 And c.Row > Row1
End Select
WithinTheBox = WithinTheBox And _
c.Column >= col1 And c.Column < col1 + ColCount - 1
End Function
Private Sub swapThem(range10 As Range, range20 As Range)
'Unlike with SUB 'Matching_R_ange', we have to swap the %s as well as the items
'So set temporary range vars to hold %s, to avoid confusion due to referencing items/r_anges
If ColumnsPer = 2 Then
Dim range11 As Range
Set range11 = range10.Offset(0, 1)
Dim range21 As Range
Set range21 = range20.Offset(0, 1)
'sit on them for now
End If
Dim Stak As Object
Set Stak = CreateObject("System.Collections.Stack")
Stak.push (range10.Value) 'A
Stak.push (range20.Value) 'BA
range10.Value = Stak.pop 'A
range20.Value = Stak.pop '_ Stak is empty now, can re-use
If ColumnsPer = 2 Then
Stak.push (range11.Value)
Stak.push (range21.Value)
range11.Value = Stak.pop
range21.Value = Stak.pop
End If
End Sub
What I need (alphabetical numbering of rows-highlighted in bold(serial column)):
I have tried converting the output of rownumber function into string, But nothing seems to work as I don't have any idea.
Please help!
You can do this with a bit of custom code.
Go to the Report Properties, click the "Code" tab and paste the following code into the custom code window.
Public Function GetRowLetter(RowNum As Integer) As String
' stick the RowNum in a variable that we can reduce until it's zero
Dim r As Integer
Dim i As Integer
Dim s As String ' holds result
s = ""
r = RowNum
' we start at the right side so if the rownum is 28 we want to be back AB
' need to get 'B' first
Do While RowNum > 0
r = Int((RowNum - 1) / 26)
i = (RowNum - 1) Mod 26
s = Chr(i + 65) & s
RowNum = r
Loop
GetRowLetter = s
End Function
This will give "A" for 1, "B" for 2 etc, then it will give "AA" for 27, "AB" or 28 etc...
If you want to return lower case letters instead, swap the 65 for 98
In your report set the textbox value expression to
=Code.GetRowLetter(RowNumber("myDataSetName"))
swap out myDataSetName with the name of your dataset or scope you want to apply it to. Remember the dataset and scope names are case sensitive and must be surrounded by quotes ( " )
There are some solutions to the predicament I have now but non ive found so far are sufficient to how I want to apply it.
I am creating an application that should have the unique random NUMERIC string concatenated into a Reference number. Here is one of the solutions I found:
Sub test()
Dim s As String * 8 'fixed length string with 8 characters
Dim n As Integer
Dim ch As Integer 'the character
For n = 1 To Len(s) 'don't hardcode the length twice
Do
ch = Rnd() * 127 'This could be more efficient.
'48 is '0', 57 is '9', 65 is 'A', 90 is 'Z', 97 is 'a', 122 is 'z'.
Loop While ch < 48 Or ch > 57 And ch < 65 Or ch > 90 And ch < 97 Or ch > 122
Mid(s, n, 1) = Chr(ch) 'bit more efficient than concatenation
Next
Debug.Print s
End Sub
Unfortunately it just creates one string and it is an alphabetic one. Im having difficulty converting VB.net code to VBA and thus I need to get a MS Access VBA solution that creates a unique numeric string of 5 characters every time the procedure is run.
You can use:
Dim Number As Long
Randomize
Number = Int(Rnd * 10 ^ 5)
To have leading zeroes and a string
Dim Number As Long
Randomize
Number = Format(Int(Rnd * 10 ^ 5), "00000")
I have a table linked to a form where a user enters an ISBN number. I'm checking to make sure the ISBN is valid. However, when I get to a point where I need to compare two numbers, I am incorrectly told that they do not match, when they definitely do match.
Private Sub isbn_BeforeUpdate(Cancel As Integer)
Dim isbn As String
Dim cleanIsbn As Double
Dim onlyIsbn As Double
Dim checkDigit As Integer
Dim legnth As Integer
length = 0
isbn = Forms!frmPubInfo!isbn.Value
' Strip out all hyphens
For i = 1 To Len(isbn)
Dim ch As String
ch = Mid(isbn, i, 1)
If IsNumeric(ch) Then
length = length + 1
Dim num As Integer
num = CInt(ch)
cleanIsbn = (cleanIsbn * 10) + num
End If
Next
' Check if 13 numbers
If length = 13 Then
Dim xBy3 As Boolean
Dim total As Integer
Dim calcCheckDigit As Integer
total = 0
xBy3 = False
' Calculate total amount
For j = 1 To 12
ch = Mid(cleanIsbn, j, 1)
If xBy3 = True Then
total = total + (ch * 3)
xBy3 = False
Else
total = total + ch
xBy3 = True
End If
Next
' Get calculated check digit
calcCheckDigit = 10 - (total Mod 10)
' Extract check digit
checkDigit = Mid(cleanIsbn, 13, 1)
' Debug output
MsgBox ("Actual CheckDigit: " & checkDigit & vbNewLine & _
"Calculated CheckDigit: " & calcCheckDigit)
' Check if check digit and calculated check digit match
If checkDigit <> calculatedCheckDigit Then
MsgBox ("checkDigit and calcCheckDigit are not the same")
Else
MsgBox ("They match! ISBN is good!")
End If
Else
' Display error
MsgBox ("Not enough numbers!")
End If
End Sub
When I get down to the 'Check if check digit and calculated check digit match', the If statement always says they don't match, even though the debug output above gives me the same two numbers.
I have tried:
Declaring the checkDigit variables as strings.
Casting the checkDigit variables as strings in the If Statement with CStr.
Casting the checkDigit variables as Integers in the If Statement with CInt.
I initially thought it was an issue with the data types, but if I'm casting them to the same type right as I'm comparing them, that can't be the issue, right?
This is all using Access 2013.
Man... I can't believe I didn't see this at first. I tested your code and got similar results as you. After looking at it closer I noticed that the if statement was wrong. In short you need to use Option Explicit and this error would have been caught. Option Explicit ensures that all variables are declared. In not an error is thrown.
You statement contains a null
If checkDigit <> calculatedCheckDigit Then
You dont have a variable called calculatedCheckDigit it should be calcCheckDigit.
If checkDigit <> calcCheckDigit Then
Just a side note: Your code for stripping out the hyphens obviously works but I offer this tweak.
' Dim as string since it is treated as one with Mid anyway.
' In practice Len didnt give accurate results while it was Double.
Dim cleanIsbn As String
' Strip out all hyphens
cleanIsbn = Replace(isbn, "-", "")
' Check if 13 numbers
If (Len(cleanIsbn) = 13) And IsNumeric(cleanIsbn) Then
' Process Stuff
Else
' Display error
MsgBox "Does not appear to be a valid ISBN value!"
End If
Take the isbn and just remove the hyphens with a replace. After that change if the result cleanIsbn is 13 characters long and numeric then you can assume its a good value to process.
ISBN Reference
I had to look it up but the math behind the ISBN numbers is located for reference here
I have a table that contains prices from several agents and from several airlines, they were divided into groups by weight charges.
Depending on the airport of departure (POL/C) and arrival (POD/C), I check all the prices and I have to use the best one. But to show the price alternatives.
Each airline has its own method of calculation, therefore I have to check.
Table contains the following information:
ID = AutoNumber, Long Integer
A/CODE = Number, Long Integer
AGENT = Text,
POL/C = Text,
POL = Text,
POD/C = Text,
POD = Text,
IATA = Text,
Airline = Text,
UPDATE = Date/Time, Short Date
EXPIRY DATE = Date/Time, Short Date
CURRENCY = Text,
M/M = Number, Double (Minimum weight accepted)
-45 = Number, Double (price for the weight between 1 and 45)
+45 = Number, Double (price for the weight starting from 45 to 100)
+100 = Number, Double (price for the weight starting from 100 to 300)
+300 = Number, Double (price for the weight starting from 300 to 500)
+500 = Number, Double (price for the weight starting from 500 to 1000)
+1000 = Number, Double (price for the weight starting from 1000)
FSC = Number, Double
SSC = Number, Double
ScGw = Yes/No, Yes/No
FREQUENCY = Text,
TT = Number, Long Integer
T/S = Yes/No, Yes/No
From the beginning it will have two weights as follows:
actual total weight (GW - gross weight)
calculated weight by volume (VW)
if GW > VW then..
calculation is based on the higher value (GW)
else
calculation is based on the higher value (VW)
example:
VW = 405 kgs and GW = 222 kgs then use higher value
FSC and SSC is added to the price if any.
Where is calculated on weight (VW) and If ScGw = Yes THEN the weight is different account and is calculated using (GW)
example:
Air freight = euro 0.25 / kgs (x 405 kgs VW)
Fuel + security = euro 1.1 / kgs (x 222 kgs GW)
If ScGw = No THEN calculate the normal VW
example:
Air freight = euro 0.25 / kgs (x 405 kgs VW)
Fuel + security = euro 1.1 / kgs (x 405 kgs VW)
If the calculation is made according to GW,
then add the FSC and SSC automatically and without having to count,
if ScGw = Yes / No
Values of GW and VW we have already calculated in another form and only need to be use.
airport of departure (POL/C) and arrival (POD/C) is already selected in another form.
If you can help me, as a few days simply fail to find any solution. I am writing full pages without any good result.
Thanks to all who respond.
I'm stuck at the moment and with the error:
Run-time error ‘3061’:
Too few parameters. Expected 2
I do not know what the problem is...
Public Sub CalculPret()
Dim da As Database
Dim rec As Recordset
Dim PolCboV As String
Dim PodCboV As String
Dim strSQL As String
Dim GrossWeight As Double
Dim VolumeWeight As Double
Dim CalcWeight As Double
Dim CalcWeightScGw As Double
Dim CalcPrice As Double
Dim TotalPrice As Double
PolCboV = [Forms]![DimensionsQry]![PolCbo]
PodCboV = [Forms]![DimensionsQry]![PodCbo]
strSQL = "SELECT Prices_List.ID, Prices_List.[A/CODE], Prices_List.AGENT, Prices_List.[POL/C], Prices_List.POL, Prices_List.[POD/C], Prices_List.POD, Prices_List.IATA, Prices_List.AIRLINE, Prices_List.UPDATE, Prices_List.[EXPIRY DATE], Prices_List.CURRENCY, Prices_List.[M/M], Prices_List.[-45], Prices_List.[+45], Prices_List.[+100], Prices_List.[+300], Prices_List.[+500], Prices_List.[+1000], Prices_List.FSC, Prices_List.SSC, Prices_List.ScGw, Prices_List.FREQUENCY, Prices_List.TT, Prices_List.[T/S]"
strSQL = strSQL & " FROM Prices_List"
strSQL = strSQL & " WHERE (((Prices_List.[POL/C])=PolCboV) AND ((Prices_List.[POD/C])=PodCboV)); "
Set da = CurrentDb
Set rec = da.OpenRecordset(strSQL)
If rec.RecordCount = 0 Then
rec.Close
Exit Sub
Else
GrossWeight = [Forms]![DimensionsQry]![Text34]
VolumeWeight = [Forms]![DimensionsQry]![Text36]
If GrossWeight > VolumeWeight Then
CalcWeight = GrossWeight
Else
If ScGw = "Yes" Then
CalcWeight = GrossWeight
Else
CalcWeight = VolumeWeight
End If
End If
rec.MoveFirst
Do Until rec.EOF
Select Case CalcWeight
Case 1 To 44
CalcPrice = rec![-45]
Case 45 To 99
CalcPrice = rec![+45]
Case 100 To 299
CalcPrice = rec![+100]
Case 300 To 499
CalcPrice = rec![+300]
Case 500 To 999
CalcPrice = rec![+500]
Case Is >= 1000
CalcPrice = rec![+1000]
End Select
If CalcWeight = GrossWeight Then
CalcPrice = CalcPrice + rec!FSC + rec!SSC
TotalPrice = CalcPrice * CalcWeight
Else
TotalPrice = (CalcPrice * CalcWeight) + ((rec!FSC + rec!SSC) * GrossWeight)
End If
MsgBox TotalPrice
rec.MoveNext
Loop
End If
rec.Close
End Sub
I have tried to rearrange your rules into execution sequence.
I have added the following variables:
CalcWeight: The weight to be used in the calculation
CalcPrice: The price to be used in the calculation
TotalPrice: Price based on weight, standard price, fuel and security
Does the following look about right?
If GrossWeight > VolumeWeight Then
CalcWeight = GrossWeight
Else
If ScGw = "Yes" Then
CalcWeight = GrossWeight
Else
CalcWeight = VolumeWeight
End If
End If
Select Case CalcWeight
Case 1 To 44
CalcPrice = Price(-45)
Case 45 to 99
CalcPrice = Price(+45)
Case 100 To 299
CalcPrice = Price(+100)
Case 300 To 499
CalcPrice = Price(+300)
Case 500 To 999
CalcPrice = Price(500)
Case Is >= 1000
CalcPrice = Price(1000)
End Select
' I am unclear about adding FSC and SSC to CalcPrice.
' It appears to be based on which weight is used but
' it may be more complicated.
If CalcWeight = GrossWeight Then
CalcPrice = CalcPrice + FSC + SSC
End If
TotalPrice = CalcPrice * CalcWeight
New section in response to extra question
I have two problems:
You do not say which statement gives the 3061 error although I suspect I know.
I have not used Access for some years.
Everything that follows is general advice that may help you isolate the cause of the error.
Issue 1
strSQL = "SELECT Prices_List.ID, Prices_List.[A/CODE], Prices_List.AGENT, Prices_List.[POL/C], Prices_List.POL, Prices_List.[POD/C], Prices_List.POD, Prices_List.IATA, Prices_List.AIRLINE, Prices_List.UPDATE, Prices_List.[EXPIRY DATE], Prices_List.CURRENCY, Prices_List.[M/M], Prices_List.[-45], Prices_List.[+45], Prices_List.[+100], Prices_List.[+300], Prices_List.[+500], Prices_List.[+1000], Prices_List.FSC, Prices_List.SSC, Prices_List.ScGw, Prices_List.FREQUENCY, Prices_List.TT, Prices_List.[T/S]"
I do not like long statements that run off the page. I would have typed this as:
strSQL = "SELECT Prices_List.ID, Prices_List.[A/CODE], Prices_List.AGENT, " & _
"Prices_List.[POL/C], Prices_List.POL, Prices_List.[POD/C], " & _
"Prices_List.POD, Prices_List.IATA, Prices_List.AIRLINE, " & _
"Prices_List.UPDATE, Prices_List.[EXPIRY DATE], Prices_List.CURRENCY, " & _
"Prices_List.[M/M], Prices_List.[-45], Prices_List.[+45], " & _
"Prices_List.[+100], Prices_List.[+300], Prices_List.[+500], " & _
"Prices_List.[+1000], Prices_List.FSC, Prices_List.SSC, " & _
"Prices_List.ScGw, Prices_List.FREQUENCY, Prices_List.TT, " & _
"Prices_List.[T/S]"
Issue 2
Do you need all these fields? When you have picked the best price you will need AGENT or A/CODE. If you do not need ID, IATA, AIRLINE, why select them?
Issue 3
You have a field CURRENCY which you do not use. Is this correct?
Issue 4
Set da = CurrentDb
I assume CurrentDb is a global variable because it is not declared or set within this subroutine.
Issue 5
Set rec = da.OpenRecordset(strSQL)
I have googled "Access Error 3061" and have received lots of questions and answers about this error. Perhaps one will help you.
If I understand correctly, Prices_List is not a table but a query with parameters and you have not included the parameters.
Issue 5
MsgBox TotalPrice
While you are trying to get your program working, Debug.Print is more useful than MsgBox.
Click on one of the early statements in this routine to place the cursor in it. Click F9. The statement will go brown to indicate it is a breakpoint.
Run your program in the normal way. When it gets to the brown statement, it will stop and display the module. The brown statement will be both brown and yellow. Brown because it is a breakpoint; yellow because it is the statement about to be executed. Click F8; one statement will be executed and the next statement will become the yellow one.
You can step through your program statement by statement checking what is happening. If you hover over a variable, its current value will be displayed. If a statement gives an error, you can change it and try again.
You can have as many breakpoints as you like. Clicking F5 causes the program to run until the next breakpoint. With F5 and F8 you can control which bits of your program you examine.
Debug.Assert rec!AGENT <> "Acme Inc" can be very useful if one part of your program is failing. This debug assert will stop the program if the agent is "Acme Inc". The syntax is Debug.Assert boolean expression. With the correct boolean expression you can stop your program where ever you want.
At the bottom of the editor screen you should see the Immediate window. If you do not, click Ctrl+G.
Debug.Print rec!AGENT & " " & TotalPrice
will output Acme Inc 543.21 to the Immediate Window and carry on. With MsgBox the program stops and you have to write down the value. The Immediate Window has a limit of two or three hundred lines which you can scroll up and down or copy to NotePad.
Summary
I hope the above helps. Best of luck.
the line
strSQL = strSQL & " WHERE (((Prices_List.[POL/C])=PolCboV) AND ((Prices_List.[POD/C])=PodCboV));"
should read
strSQL = strSQL & " WHERE (((Prices_List.[POL/C])='" & PolCboV & "') AND ((Prices_List.[POD/C])='" & PodCboV & "'));"
because PolCbov & PodCbov are variables in your code, you want their values in the SQL not their names