Problem with f2py not modifying an inout array - numpy

I have a fortran routine that takes 6 arrays as input, and modifies the content of the first array. The arrays are all numpys with the following flags
C_CONTIGUOUS : False
F_CONTIGUOUS : True
OWNDATA : False
WRITEABLE : True
ALIGNED : True
WRITEBACKIFCOPY : False
UPDATEIFCOPY : False
I tried declaring the array that needs to be modified as intent(in, out), also tried intent(inout), and using the inplace modifier, but in every case, once the routine terminates, the array that was supposed to be modified is not modified on the Python side. Using the -DF2PY_REPORT_ON_ARRAY_COPY=1 I also note that 5 arrays are copied. This of course creates a performance issue. What I am doing wrong?
This is the fortran subroutine
subroutine POISSONOP_GSRB(
& phi
& ,iphilo0,iphilo1
& ,iphihi0,iphihi1
& ,nphicomp
& ,rhs
& ,irhslo0,irhslo1
& ,irhshi0,irhshi1
& ,nrhscomp
& ,Mx
& ,iMxlo0,iMxlo1
& ,iMxhi0,iMxhi1
& ,nMxcomp
& ,My
& ,iMylo0,iMylo1
& ,iMyhi0,iMyhi1
& ,nMycomp
& ,Mz
& ,iMzlo0,iMzlo1
& ,iMzhi0,iMzhi1
& ,nMzcomp
& ,Dinv
& ,iDinvlo0,iDinvlo1
& ,iDinvhi0,iDinvhi1
& ,idestBoxlo0,idestBoxlo1
& ,idestBoxhi0,idestBoxhi1
& ,whichPass
& )
implicit none
integer nphicomp
integer iphilo0,iphilo1
integer iphihi0,iphihi1
REAL*8 phi(
& iphilo0:iphihi0,
& iphilo1:iphihi1,
& 0:nphicomp-1)
cf2py intent(in, overwrite) phi
integer nrhscomp
integer irhslo0,irhslo1
integer irhshi0,irhshi1
REAL*8 rhs(
& irhslo0:irhshi0,
& irhslo1:irhshi1,
& 0:nrhscomp-1)
cf2py intent(in, inplace) rhs
integer nMxcomp
integer iMxlo0,iMxlo1
integer iMxhi0,iMxhi1
REAL*8 Mx(
& iMxlo0:iMxhi0,
& iMxlo1:iMxhi1,
& 0:nMxcomp-1)
cf2py intent(in, inplace) Mx
integer nMycomp
integer iMylo0,iMylo1
integer iMyhi0,iMyhi1
REAL*8 My(
& iMylo0:iMyhi0,
& iMylo1:iMyhi1,
& 0:nMycomp-1)
cf2py intent(in, inplace) My
integer nMzcomp
integer iMzlo0,iMzlo1
integer iMzhi0,iMzhi1
REAL*8 Mz(
& iMzlo0:iMzhi0,
& iMzlo1:iMzhi1,
& 0:nMzcomp-1)
cf2py intent(in, inplace) Mz
integer iDinvlo0,iDinvlo1
integer iDinvhi0,iDinvhi1
REAL*8 Dinv(
& iDinvlo0:iDinvhi0,
& iDinvlo1:iDinvhi1)
cf2py intent(in, inplace) Dinv
integer idestBoxlo0,idestBoxlo1
integer idestBoxhi0,idestBoxhi1
integer whichPass
integer i,j
integer indtot, imin, imax
integer n, ncomp
REAL*8 Sphi
REAL*8 MyL
REAL*8 MyR
ncomp = nphicomp
do n = 0, ncomp-1
do j = idestBoxlo1, idestBoxhi1
MyL = My(0,j,0)
MyR = My(0,j,1)
imin = idestBoxlo0
indtot = imin + j
imin = imin + abs(mod(indtot + whichPass, 2))
imax = idestBoxhi0
do i = imin, imax, 2
Sphi =
& Mx(i,0,0) * phi(i-1,j,n)
& + Mx(i,0,1) * phi(i+1,j,n)
& + MyL * phi(i,j-1,n)
& + MyR * phi(i,j+1,n)
phi(i,j,n) = Dinv(i,j)
& * (rhs(i,j,n) - Sphi)
enddo
enddo
enddo
return
end
and this is how it is called on Python
GS.poissonop_gsrb(phi.data,phi.box.LoEnd()[0],phi.box.LoEnd()[1],phi.box.HiEnd()[0], phi.box.HiEnd()[1],
rhs.data,rhs.box.LoEnd()[0],rhs.box.LoEnd()[1],rhs.box.HiEnd()[0], rhs.box.HiEnd()[1],
Mx.data,Mx.box.LoEnd()[0],Mx.box.LoEnd()[1],Mx.box.HiEnd()[0], Mx.box.HiEnd()[1],
My.data,My.box.LoEnd()[0],My.box.LoEnd()[1],My.box.HiEnd()[0], My.box.HiEnd()[1],
Mz.data,Mz.box.LoEnd()[0],Mz.box.LoEnd()[1],Mz.box.HiEnd()[0], Mz.box.HiEnd()[1],
DInv.data,DInv.box.LoEnd()[0],DInv.box.LoEnd()[1],DInv.box.HiEnd()[0], DInv.box.HiEnd()[1],
L[0], L[1],H[0], H[1], whichPass,
)
Note that the last dimension of the arrays is inferred and thus not specified.

Related

Why is 31 >= 20 returning False here when comparing day?

I was debugging this code but I am not sure why this is returning false instead of true.
?Day(i)>salday(0)
False
?Day(i)
31
?salday(0)
20
?isnumeric(day(i))
True
?isnumeric(salday(0))
True
Option Explicit
Option Compare Text
Sub genOP()
Dim wO As Worksheet
Dim i As Long, j As Long
Dim stDate, enDate, intVal, entR As Long, salDay, salAmt, stTime, enTime, dbMin, dbMax
Dim stRow As Long
Dim cet, curMn
'On Error Resume Next
Application.ScreenUpdating = False
stDate = STG.Range("B2"): enDate = STG.Range("B4")
intVal = Split(STG.Range("B3"), ","): entR = STG.Range("B5")
salDay = Split(STG.Range("B6"), "-")
salAmt = STG.Range("B7"): stTime = STG.Range("B8"): enTime = STG.Range("B9"): dbMin = STG.Range("B10"): dbMax = STG.Range("B11")
Set wO = ThisWorkbook.Sheets.Add
TEMP.Cells.Copy wO.Range("A1")
stRow = 19
curMn = Month(stDate)
For i = CLng(stDate) To CLng(enDate)
If stRow > 19 Then
wO.Rows(stRow & ":" & stRow).Copy
wO.Rows(stRow + 1 & ":" & stRow + 1).Insert Shift:=xlDown
Application.CutCopyMode = False
End If
cet = Trim(DESC.Range("A" & WorksheetFunction.RandBetween(2, DESC.UsedRange.Rows.Count)))
If STG.Range("B14") = "ON" Then
cet = cet & "Transaction amount " & Chr(34) & "&TEXT(H" & stRow & "," & Chr(34) & "#,##0.00" & Chr(34) & ")&" & Chr(34) & " GEL,"
End If
If STG.Range("B13") = "ON" Then
cet = cet & Chr(34) & "&TEXT(B" & stRow & "-1," & Chr(34) & "dd mmm yyyy" & Chr(34) & ")&" & Chr(34)
End If
If STG.Range("B12") = "ON" Then
cet = cet & " " & Format(stTime + Rnd * (enTime - stTime), "HH:MM AM/PM")
End If
If curMn = Month(i) And (Day(i) >= salDay(0) And Day(i) <= salDay(1)) Then 'Salary Day
cet = Trim(DESC.Range("A" & WorksheetFunction.RandBetween(2, DESC.UsedRange.Rows.Count)))
wO.Range("B" & stRow) = Format(i, "DD-MM-YYYY")
wO.Range("I" & stRow) = salAmt
wO.Range("L" & stRow) = MonthName(Month(i)) & "- Salome Baazov - " & "Geo" & " Ltd "
curMn = WorksheetFunction.EDate(i, 1)
Else
wO.Range("B" & stRow) = Format(i, "DD-MM-YYYY")
wO.Range("H" & stRow) = WorksheetFunction.RandBetween(dbMin, dbMax) + (WorksheetFunction.RandBetween(0, 1) * 0.5)
wO.Range("L" & stRow) = "=" & Chr(34) & cet & Chr(34)
End If
stRow = stRow + 1
i = i + intVal(WorksheetFunction.RandBetween(LBound(intVal), UBound(intVal))) - 1
Next i
wO.Rows(stRow).EntireRow.Delete
wO.Range("I" & stRow).Formula = "=SUM(I19:I" & stRow - 1 & ")"
wO.Range("H" & stRow).Formula = "=SUM(H19:H" & stRow - 1 & ")"
wO.Activate
Application.ScreenUpdating = True
STG.Range("B5") = stRow - 1
MsgBox "Process Completed"
End Sub
Because you are comparing two Variants with different types (As it turned out after our discussions... thx #MatsMug). The comparison result is undefined behavior when comparing Variants of different types, one numeric and one String.
It's the Variant anomalies once again.. Consider this MCVE:
Sub Test1()
Dim i, salday
i = CDate("5/30/2017")
salday = Split("20-20-20", "-")
Debug.Print Day(i), salday(0) ' 30 20
Debug.Print Day(i) > salday(0) ' False
Debug.Print Day(i) > CStr(salday(0)) ' True
' ^^^^
Debug.Print Val(Day(i)) > salday(0) ' True
' ^^^^
End Sub
Although salday(0) is a String Variant, explicitly converting it to String with CStr solved the issue. However, without that conversion, the comparison failed. VBA did not implicitly convert the number to a string or vice-versa. It compared two Variants of different types and returned a rubbish result.
For more about the Variant curse, read For v=1 to v and For each v in v -- different behavior with different types
As it turns out, using CLng or Val to force number comparison is the safe way to go, or CStr to force text comparison.
Consider further these three simple examples:
Sub Test1()
Dim x, y: x = 30: y = "20"
Debug.Print x > y ' False !!
End Sub
Sub Test2()
Dim x As Long, y: x = 30: y = "20"
' ^^^^^^
Debug.Print x > y ' True
End Sub
Sub Test3()
Dim x, y As String: x = 30: y = "20"
' ^^^^^^
Debug.Print x > y ' True
End Sub
As you can see, when both variables, the number and the string, were declared variants, the comparison is rubbish. When at least one of them is explicit, the comparison succeeds!
Dim stDate, enDate
This instruction declares two Variant variables. They're assigned here:
stDate = STG.Range("B2"): enDate = STG.Range("B4")
Assuming [B2] and [B4] contain actual date values, at that point the variables contain a Variant/Date. That's because the implicit code here is as follows:
stDate = STG.Range("B2").Value: enDate = STG.Range("B4").Value
But you probably know that already. Moving on.
salDay = Split(STG.Range("B6"), "-")
salDay is also an implicit Variant. That instruction is quite loaded though. Here's the implicit code:
salDay = Split(CStr(STG.Range("B6").Value), "-")
This makes salDay an array of strings. So here we are:
?Day(i)
31
?salday(0)
20
The leading space in front of 31 is because the immediate pane always leaves a spot for a negative sign. salDay(0) being a String, there's no leading space. That was your clue right there.
?Day(i)>salday(0)
False
With salday(0) being a String, we're doing a string comparison here, as was already pointed out. Except there's no leading space in front of the 31; the implicit code is this, because the type of Day(i) is Integer:
?CStr(Day(i)) > salDay(0)
False
The solution is to get rid of salDay altogether: you don't need it. Assuming [B6] also contains an actual date, you can get the day into an Integer right away:
?Day(STG.Range("B6").Value)
As a bonus you decouple your code from the string representation of the underlying date value that's in your worksheet, so changing the NumberFormat won't break your code. Always treat dates as such!

Visual Basic: how can I display certain values from a group of characters

Here we are finding the eight adjacent numbers that have the highest sum and displaying that sum. We also need to have it display the eight adjacent numbers that add up to this value. I am stuck on how to display these values. My code for what I have so far is below:
Dim chars As Char() = "73167176531330624919225119674426574742355349194934" &
"96983520312774506326239578318016984801869478851843" &
"85861560789112949495459501737958331952853208805511" &
"12540698747158523863050715693290963295227443043557" &
"66896648950445244523161731856403098711121722383113" &
"62229893423380308135336276614282806444486645238749" &
"30358907296290491560440772390713810515859307960866" &
"70172427121883998797908792274921901699720888093776" &
"65727333001053367881220235421809751254540594752243" &
"52584907711670556013604839586446706324415722155397" &
"53697817977846174064955149290862569321978468622482" &
"83972241375657056057490261407972968652414535100474" &
"82166370484403199890008895243450658541227588666881" &
"16427171479924442928230863465674813919123162824586" &
"17866458359124566529476545682848912883142607690042" &
"24219022671055626321111109370544217506941658960408" &
"07198403850962455444362981230987879927244284909188" &
"84580156166097919133875499200524063689912560717606" &
"05886116467109405077541002256983155200055935729725" &
"71636269561882670428252483600823257530420752963450"
Dim index As String = 0
Dim x = 0
Dim values = Array.ConvertAll(chars, Function(c) CInt(c.ToString()))
Dim maxSum = 0
For i = 0 To values.Length - 8
Dim sum = values(i)
For x = i + 1 To i + 7
sum += values(x)
index = i
Next
If sum > maxSum Then
maxSum = sum
End If
Next
Console.WriteLine(index)
Console.WriteLine(maxSum)
Console.Read()
End Sub
Here's my take on it using two different approaches. The first is a more traditional approach, while the second utilizes LINQ:
Sub Main()
Dim chunkSize As Integer = 8
Dim source As String =
"73167176531330624919225119674426574742355349194934" &
"96983520312774506326239578318016984801869478851843" &
"85861560789112949495459501737958331952853208805511" &
"12540698747158523863050715693290963295227443043557" &
"66896648950445244523161731856403098711121722383113" &
"62229893423380308135336276614282806444486645238749" &
"30358907296290491560440772390713810515859307960866" &
"70172427121883998797908792274921901699720888093776" &
"65727333001053367881220235421809751254540594752243" &
"52584907711670556013604839586446706324415722155397" &
"53697817977846174064955149290862569321978468622482" &
"83972241375657056057490261407972968652414535100474" &
"82166370484403199890008895243450658541227588666881" &
"16427171479924442928230863465674813919123162824586" &
"17866458359124566529476545682848912883142607690042" &
"24219022671055626321111109370544217506941658960408" &
"07198403850962455444362981230987879927244284909188" &
"84580156166097919133875499200524063689912560717606" &
"05886116467109405077541002256983155200055935729725" &
"71636269561882670428252483600823257530420752963450"
Dim strChunk As String
Dim strMaxChunk As String = ""
Dim curSum, MaxSum As Integer
Dim values() As Integer
For i As Integer = 0 To source.Length - chunkSize
strChunk = source.Substring(i, chunkSize)
values = Array.ConvertAll(strChunk.ToCharArray, Function(c) CInt(c.ToString()))
curSum = values.Sum
If curSum > MaxSum Then
MaxSum = curSum
strMaxChunk = strChunk
End If
Next
Console.WriteLine("Traditional")
Console.WriteLine("Max Sum = " & MaxSum & " from " & strMaxChunk)
Dim sums = From chunk In Enumerable.Range(0, source.Length - chunkSize).Select(Function(x) source.Substring(x, chunkSize))
Select chunk, sum = Array.ConvertAll(chunk.ToCharArray, Function(y) CInt(CStr(y))).Sum
Order By sum Descending
Dim linqResult = sums.First
Console.WriteLine("Linq")
Console.WriteLine("Max Sum = " & linqResult.sum & " from " & linqResult.chunk)
Console.ReadLine()
End Sub

First line of sub before loop

This function breaks up one long continuous string into smaller ones and adds a prefix and suffix/
This line of code is giving me problems I need it because the first prefix is different to the others but it causes the first line to be produced twice not sure how to rewrite the line /code overcome this?
.WriteLine "s = """ & Trim$(Mid$(strInput, 1, intSize * AtomSize)) & """"
Here is the full suc:
Sub StringBuilder(intSize As Integer, Optional AtomSize As Long = 3)
Dim i As Long
Dim strInput As String
strInput = CreateObject("Scripting.FileSystemObject").OpenTextFile(CurrentProject.Path & "\input.txt").ReadAll
With CreateObject("Scripting.FileSystemObject").CreateTextFile(CurrentProject.Path & "\output.txt", True)
.WriteLine "s = """ & Trim$(Mid$(strInput, 1, intSize * AtomSize)) & """"
For i = 1 To Len(strInput) - intSize * AtomSize Step intSize * AtomSize
.WriteLine "s = s & """ & Trim$(Mid$(strInput, i, intSize * AtomSize)) & """"
Next
.WriteLine "s = s & """ & Trim$(Mid$(strInput, i, intSize * AtomSize)) & """"
End With
End Sub
Simple change
.WriteLine "s = """ & Trim$(Mid$(strInput, 1, intSize * AtomSize)) & """"
To
.WriteLine "s = """
Sub StringBuilder(intSize As Integer, Optional AtomSize As Long = 3)
Dim i As Long
Dim strInput As String
strInput = CreateObject("Scripting.FileSystemObject").OpenTextFile(CurrentProject.Path & "\input.txt").ReadAll
With CreateObject("Scripting.FileSystemObject").CreateTextFile(CurrentProject.Path & "\output.txt", True)
.WriteLine "s = """
For i = 1 To Len(strInput) - intSize * AtomSize Step intSize * AtomSize
.WriteLine "s = s & """ & Trim$(Mid$(strInput, i, intSize * AtomSize)) & """"
Next
.WriteLine "s = s & """ & Trim$(Mid$(strInput, i, intSize * AtomSize)) & """"
End With
End Sub
Here is a function which can be used to divide a string into groups:
Function GroupString(s As String, groupSize As Long, _
Optional delim As String = ",", _
Optional prefix As String = "", _
Optional postfix As String = "") As String
Dim n As Long, m As Long, i As Long
Dim chunks As Variant
n = Len(s)
m = Int(n / groupSize)
If n Mod groupSize = 0 Then
ReDim chunks(0 To m - 1)
Else
ReDim chunks(0 To m) 'includes final chunk of size < groupSize
End If
For i = 0 To m - 1
chunks(i) = Mid(s, 1 + i * groupSize, groupSize)
Next i
If n Mod groupSize > 0 Then
chunks(m) = Mid(s, 1 + m * groupSize) 'final chunk
End If
GroupString = prefix & Join(chunks, delim) & postfix
End Function
To test it:
Sub test()
Dim myString As String
myString = "abcd"
Debug.Print GroupString(myString, 2, , "[", "]")
myString = "This is a very long string, it would be nice if it were split into several lines, where each line is assigned to a variable"
Debug.Print GroupString(myString, 20, """" & vbCrLf & "s = s & """, "s = """, """")
End Sub
With output:
[ab,cd]
s = "This is a very long "
s = s & "string, it would be "
s = s & "nice if it were spli"
s = s & "t into several lines"
s = s & ", where each line is"
s = s & " assigned to a varia"
s = s & "ble"
To use it for your problem: read the input file into a string, and then in a single write operation, use a single write operation to write the result of the function applied to the string, using a call similar to the second example in my test code.

How to display calculations, values and variables in Excel?

For didactic purposes I like to perform and display calculations in Excel. To display calculations I use the following VBA worksheet-function:
Function DisplayFormula(range_rng As Range) As String
Application.Volatile
If range_rng.HasArray Then
DisplayFormula = "<-- " & " {" & range_rng.FormulaArray & "}"
Else
DisplayFormula = "<-- " & " " & range_rng.FormulaArray
End If
End Function
This works, however, I'm stuck with the implementation of two modifications:
I would like to display the actual values that are called in range_rng.
I would like to display variables instead of the ranges. The variables would be assigned in a separate cell, next to the cell where they are called from (see graphic below).
Column "C" shows the (desired) output formats for DisplayFormula(B3):
You can try this brute force approach.
I can't say that this is optimized, but it can satisfy your two conditions above.
Function DisplayFormula2(r As Range, Optional o As Variant) As String
Dim a, b, z, x, y, w
Dim f As String, tf As String
Dim c As Range
Dim i As Integer
If IsMissing(o) Then o = 0
a = Array("+", "-", "/", "*", "%", "&", "^", "=", _
"<", ">", "<=", ">=", "<>", "(", ")")
f = r.FormulaArray: tf = f
For Each b In a
With Application.WorksheetFunction
tf = .Substitute(tf, b, "|")
End With
Next
z = VBA.Split(tf, "|")
For Each w In z
Debug.Print w
On Error Resume Next
Set c = Range(w)
On Error GoTo 0
If Not c Is Nothing Then
If IsArray(x) Then
ReDim Preserve x(UBound(x) + 1): x(UBound(x)) = w
ReDim Preserve y(UBound(y) + 1): y(UBound(y)) = c.Offset(0, o).Value2
Else
x = Array(w)
y = Array(c.Offset(0, o).Value2)
End If
End If
Set c = Nothing
Next
If IsArray(x) Then
For i = LBound(x) To UBound(x)
With Application.WorksheetFunction
f = .Substitute(f, x(i), y(i))
End With
Next
End If
DisplayFormula2 = IIf(r.HasArray, "<-- {" & f & "}", "<-- " & f)
End Function
By the way, I don't think you need to use .Volatile so I removed it.
It will recalculate as long as you set Calculation mode to Automatic.
Actual Formula in C3:C5:
C3: =DisplayFormula(B3)
C4: =DisplayFormula2(B4)
C5: =DisplayFormula2(B5,-1)
You can achieve that by changing the target cell to TEXT format. Try this:
Function DisplayFormula(range_rng As Range) As String
Application.Volatile
ActiveCell.NumberFormat = "#"
If range_rng.HasArray Then
DisplayFormula = "<-- " & " {" & range_rng.FormulaArray & "}"
Else
DisplayFormula = "<-- " & " " & range_rng.FormulaArray
End If
End Function

"system resource exceeded" when running a function

I have a field called "sku" which uniquely identifies products on the table, there are about 38k products. I have a "sku generator" which uses other fields in the table to create the SKU. It's worked perfectly without an issue until I started producing SKUs for a large amount of products. I would launch the generator and it would stop around 15,000 and say "System Resource exceeded" and highlight the following code in the function:
Found = IsNull(DLookup("sku", "Loadsheet", "[sku]='" & TempSKU & "'"))
I didn't have time to fully fix the issue, so a temporary fix for me was to split the database in two, and run the sku generator seperately on both files. Now that I have more time I want to investigate why exactly it gets stuck around this number, and if there's a possibility of fixing this issue (it would save some time with splitting files and then grouping them again). I also have an issue with it getting really slow at times, but I think it's because it's processing so much when it runs. Here is the function
Option Compare Database
Private Sub Command2_Click() 'Generate SKU
Command2.Enabled = False: Command3.Enabled = False: Command2.Caption = "Generating ..."
Me.RecordSource = ""
CurrentDb.QueryDefs("ResetSKU").Execute
Me.RecordSource = "loadsheet_4"
Dim rs As Recordset, i As Long
Set rs = Me.Recordset
rs.MoveLast: rs.MoveFirst
For i = 0 To rs.RecordCount - 1
rs.AbsolutePosition = i
rs.Edit
rs.Fields("sku") = SetSKU(rs)
rs.Update
DoEvents
Next
Command2.Enabled = True: Command3.Enabled = True: Command2.Caption = "Generate SKU"
End Sub
Public Function SetSKU(rs As Recordset) As String
Dim TempStr As String, TempSKU As String, id As Integer, Found As Boolean, ColorFound As Variant
id = 1: ColorFound = DLookup("Abbreviated", "ProductColors", "[Color]='" & rs.Fields("single_color_name") & "'")
TempStr = "ORL-" & UCase(Left(rs.Fields("make"), 2)) & "-"
TempStr = TempStr & Get1stLetters(rs.Fields("model"), True) & rs.Fields("year_dash") & "-L-"
TempStr = TempStr & "WR-"
TempStr = TempStr & IIf(IsNull(ColorFound), "?", ColorFound) & "-4215-2-"
TempStr = TempStr & rs.Fields("color_code")
TempSKU = Replace(TempStr, "-L-", "-" & ADDZeros(id, 2) & "-L-")
Found = IsNull(DLookup("sku", "Loadsheet", "[sku]='" & TempSKU & "'"))
While Found = False
id = id + 1
TempSKU = Replace(TempStr, "-L-", "-" & ADDZeros(id, 2) & "-L-")
Found = IsNull(DLookup("sku", "Loadsheet", "[sku]='" & TempSKU & "'"))
Wend
If id > 1 Then
' MsgBox TempSKU
End If
SetSKU = TempSKU
End Function
Public Function Get1stLetters(Mystr As String, Optional twoLetters As Boolean = False) As String
Dim i As Integer
Get1stLetters = ""
For i = 0 To UBound(Split(Mystr, " ")) 'ubound gets the number of the elements
If i = 0 And twoLetters Then
Get1stLetters = Get1stLetters & UCase(Left(Split(Mystr, " ")(i), 2))
GoTo continueFor
End If
Get1stLetters = Get1stLetters & UCase(Left(Split(Mystr, " ")(i), 1))
continueFor:
Next
End Function
Public Function ADDZeros(N As Integer, MAX As Integer) As String
Dim NL As Integer
NL = Len(CStr(N))
If NL < MAX Then
ADDZeros = "0" & N 'StrDup(MAX - NL, "0") & N
Else: ADDZeros = N
End If
End Function
Notes: This function also calls other functions as well that adds a unique identifier to the SKU and also outputs the first letter of each word of the product
Also I'm running on 64 bit access.
If you require any other info let me know, I didn't post the other functions but if needed let me know.
thanks.
I am not 100% sure how you have split the Database into two files and that you are running the generator on both files. However I have a few suggestion to the function you are using.
I would not pass the recordset object to this function. I would rather pass the ID or unique identifier, and generate the recordset in the function. This could be a good start for efficiency.
Next, declare all objects explicitly, to avoid library ambiguity. rs As DAO.Recordset. Try to make use of inbuilt functions, like Nz().
Could Get1stLetters method be replaced with a simple Left() function? How about ADDZeros method?
Using DLookup might be a bit messy, how about a DCount instead? Could the following be any use now?
Public Function SetSKU(unqID As Long) As String
Dim TempStr As String, TempSKU As String
Dim id As Integer
Dim ColorFound As String
Dim rs As DAO.Recordset
id = 1
Set rs = CurrentDB.OpenRecordset("SELECT single_color_name, make, model, year_dash, color_code " & _
"FROM yourTableName WHERE uniqueColumn = " & unqID)
ColorFound = Nz(DLookup("Abbreviated", "ProductColors", "[Color]='" & rs.Fields("single_color_name") & "'"), "?")
TempStr = "ORL-" & UCase(Left(rs.Fields("make"), 2)) & "-"
TempStr = TempStr & Get1stLetters(rs.Fields("model"), True) & rs.Fields("year_dash") & "-L-"
TempStr = TempStr & "WR-"
TempStr = TempStr & ColorFound & "-4215-2-"
TempStr = TempStr & rs.Fields("color_code")
TempSKU = Replace(TempStr, "-L-", "-" & ADDZeros(id, 2) & "-L-")
While DCount("*", "Loadsheet", "[sku]='" & TempSKU & "'") <> 0
id = id + 1
TempSKU = Replace(TempStr, "-L-", "-" & ADDZeros(id, 2) & "-L-")
Wend
If id > 1 Then
'MsgBox TempSKU'
End If
Set rs = Nothing
SetSKU = TempSKU
End Function