I'm trying to get it to take multiple values from an input and if there is say 2 values then to put those into SAP in two unique spots. When I run the macro with a value of "007" for example it pulls up an error in the section "If j = 7", but it should run the section "If j = 1" instead. I'm confused as to why it is doing this.
(This is not all the code just the relevant bits)
Public MRP As String
Public dNext_Monday As Date
Public WK As String
Public LR As Long
Public iWindowState As Integer
Public strEntries As String, inputArray() As String, j As Variant
strEntries = Application.InputBox("Enter multiple comma separated MRP Controllers. Ex: 007,009,016 ", "MRP Entries", Type:=2)
If strEntries = "False" Then Exit Sub 'User canceled
inputArray = Split(strEntries, ",")
j = UBound(inputArray) - LBound(inputArray) + 1
For Each j In inputArray
If j = 1 Then
session.findById("wnd[1]/usr/tabsTAB_STRIP/tabpSIVA/ssubSCREEN_HEADER:SAPLALDB:3010/tblSAPLALDBSINGLE/ctxtRSCSEL_255-SLOW_I[1,0]").Text = inputArray(0)
End If
If j = 2 Then
session.findById("wnd[1]/usr/tabsTAB_STRIP/tabpSIVA/ssubSCREEN_HEADER:SAPLALDB:3010/tblSAPLALDBSINGLE/ctxtRSCSEL_255-SLOW_I[1,0]").Text = inputArray(0)
session.findById("wnd[1]/usr/tabsTAB_STRIP/tabpSIVA/ssubSCREEN_HEADER:SAPLALDB:3010/tblSAPLALDBSINGLE/ctxtRSCSEL_255-SLOW_I[1,1]").Text = inputArray(1)
End If
Not an SAP user, but try the following, iterating the array using a For ... Next loop with LBound and UBound, and concatenating j into the ID with &.
inputArray = Split(strEntries, ",")
Dim j As Long ' remove the j As Variant from earlier
For j = Lbound(inputArray) to Ubound(inputArray)
session.findById("wnd[1]/usr/tabsTAB_STRIP/tabpSIVA/ssubSCREEN_HEADER:SAPLALDB:3010/tblSAPLALDBSINGLE/ctxtRSCSEL_255-SLOW_I[1," & j & "]").Text = inputArray(j)
Next
Related
This question is based on this puzzle that I am trying to do in vba: https://codegolf.stackexchange.com/questions/166765/fun-with-strings-and-numbers
Basically we have strings in col A and numbers in column B and in column C we have to generate a list so that:
The total count of any string should be exactly equal to its
corresponding number in the input data.
No string should be repeated adjacently in the sequence, and every
string should appear in the output list.
The selection of the next string should be done randomly as long as
they don't break above two rules. Each solution should have a
non-zero probability of being chosen.
If no combination is possible, the output should be just 0.
I tried this but I don't how to solve the problem so that it doesn't break rule #2. Any input would be appreciated thanks.
Sub generateList()
Application.ScreenUpdating = False
Dim fI As Long, totTimes As Long, i As Long, j As Long, fO As Long, tryCount As Long
Dim myArr()
Dim randNum As Long
OUT.Range("A1:A" & OUT.Rows.Count).Clear
fO = 1
With DATA
fI = .Range("A" & .Rows.Count).End(xlUp).Row
If fI < 2 Then MsgBox "No data!": Exit Sub
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("B2:B" & fI), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With DATA.Sort
.SetRange DATA.Range("A1:B" & fI)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
fI = .Range("A" & .Rows.Count).End(xlUp).Row
If fI < 2 Then MsgBox "No data!": Exit Sub
totTimes = 0: j = 0
For i = 2 To fI
If Trim(.Range("A" & i).Value) <> "" And IsNumeric(.Range("B" & i).Value) Then j = j + 1
Next i
If j < 1 Then MsgBox "No valid data present. Make sure column B has numbers and column A some string.": Exit Sub
ReDim Preserve myArr(1 To j, 1 To 2)
j = 0
For i = 2 To fI
If Trim(.Range("A" & i).Value) <> "" And IsNumeric(.Range("B" & i).Value) Then
totTimes = totTimes + CLng(.Range("B" & i).Value)
j = j + 1
myArr(j, 1) = .Range("A" & i)
myArr(j, 2) = .Range("B" & i)
End If
Next i
Do While totTimes > 0
randNum = WorksheetFunction.RandBetween(1, j)
If myArr(randNum, 2) > 0 Then
totTimes = totTimes - 1
OUT.Range("A" & fO) = myArr(randNum, 1)
myArr(randNum, 2) = myArr(randNum, 2) - 1
fO = fO + 1
End If
tryAgain:
Loop
End With
Application.ScreenUpdating = True
OUT.Activate
MsgBox "Process Completed"
End Sub
I have a solution (that isn't based on yours, unfortunately) that gives correct results... some of the time. I think I know why it falls short, I just have given up on fixing it.
It's also terrible for golfing, since it's a rather large amount of code, and it's an unholy mishmash of different approaches and implementation ideas that I made up as I went (and I never cleaned it up properly)... but maybe some of this will inspire you to get further.
As per rule #3, I select each letter at random. It was hit and miss using only that approach so I moved to weighted probabilities, which is what the code further down uses - and it seems to work somewhat well. Occasionally there will be 1 letter too many for one of the elements, or there will be adjacent equal elements, so it doesn't actually solve the puzzle all the time.
Ideas to remedy this problem:
Adjust the probability weights based on the frequency each letter has already been used. If you set dbg to true, you'll see that I implemented some calculations with that in mind, but never got around to figuring out how to actually adjust the weights themselves.
Hardcode a check or two for how many letters have been used early in the result, for the largest element group
Change the rand section to make more than 1 pass (maybe best out of 3) - the weights are sorted by "size", so doing 3 (or n) passes should increasingly favor the larger element groups
Maybe a combination of the first and the last suggestion.
Here's the code:
Sub NonRepeatSort(v() As String)
Dim lElementCount As Long
Dim lElement As Element ' Largest
Dim tElement As Long ' Total element count
Dim tEleGroups As Long ' Number of groups of elements
Dim tEle As Element
Dim e As Element
Dim EleCol As New Collection
Dim dbg As Boolean
dbg = False
Dim s As String, res As String, previousRes As String, inputString As String
Dim lCounter As Long
For i = 1 To UBound(v)
' Check if element already exists
On Error Resume Next
s = ""
s = EleCol.Item(v(i, 1))
On Error GoTo 0
' If not, create new
If s = "" Then
Set tEle = New Element
With tEle
.SetName = v(i, 1)
.SetTotal = CLng(v(i, 2))
End With
EleCol.Add Item:=tEle, Key:=tEle.Name
End If
Next i
For Each e In EleCol
' Find the largest element
If e.Total > lElementCount Then
lElementCount = e.Total
Set lElement = e
End If
' Count total elements
tElement = tElement + e.Total
' And groups
tEleGroups = tEleGroups + 1
' Generate inputstring
For k = 1 To e.Total
inputString = inputString + e.Name
Next k
Next e
' If the largest element is larger than the total remaining elements, we'll break rule 4
If lElement.Total - (tElement - lElement.Total) > 1 Then
Debug.Print "0"
GoTo EndForSomeReason
End If
' Bubble sort - lowest to highest
' Adapted from https://stackoverflow.com/a/3588073/4604845
Dim tmpE As Element
For x = 1 To EleCol.Count - 1
For y = 1 To EleCol.Count
If EleCol.Item(x).Total > EleCol.Item(y).Total Then
Set tmpE = EleCol.Item(y)
EleCol.Remove y
EleCol.Add tmpE, tmpE.Name, x
End If
Next y
Next x
' Weighted probability array
Dim pArr() As Variant, tmpProb As Double
ReDim Preserve pArr(1 To 2, 1 To EleCol.Count)
For u = 1 To UBound(pArr, 2)
Set pArr(2, u) = EleCol.Item(u)
tmpProb = tmpProb + pArr(2, u).Freq(tElement)
pArr(1, u) = tmpProb
Next u
' The meat of it
Dim r As Long, lBool As Boolean, sLen As Long, o As Double, t As Long
For j = 1 To tElement
Do
' Reset loop control
lBool = False
' Generate a random number between 1 and 100 _
to decide which group we pick a letter from
r = Rand1To100
For i = 1 To UBound(pArr, 2)
If r <= pArr(1, i) And Not r > pArr(1, i) Then
If dbg Then Debug.Print "Probability match: " & pArr(2, t).Name
t = i
Exit For
End If
Next i
Set tEle = EleCol.Item(t)
If dbg Then Debug.Print "Name: " & tEle.Name
' If the random group is different from the previous result, proceed
If tEle.Name <> previousRes Then
lBool = True
Else
If dbg Then Debug.Print "This was also the previous result - skipping"
End If
' If the use-frequency for the random group is lower than _
how many times it appears in the string, proceed
If lBool Then
o = Round((tEle.Used / tElement) * 100, 5)
If dbg Then Debug.Print "Freq: " & tEle.Freq(tElement)
If dbg Then Debug.Print "Used: " & tEle.UsedFreqI()
If dbg Then Debug.Print "res%: " & Round((Len(res) / tElement) * 100, 1)
If dbg Then Debug.Print "o : " & o
' check use-frequency against modeled frequency
If o < tEle.Freq(tElement) Then
If dbg Then Debug.Print "Proceed with " & tEle.Name
lBool = True
Else
lBool = False
End If
End If
If dbg Then Debug.Print "----------"
lCounter = lCounter + 1
Loop While (Not lBool And lCounter < 1000)
tEle.IncrementUsed
res = res + tEle.Name
previousRes = tEle.Name
Next j
' Generate results
Debug.Print "INPUT : " & inputString
Debug.Print "RESULT: " & res
EndForSomeReason:
End Sub
Function Rand1To100() As Long
Dim r As Long
Randomize
r = ((100 - 1) * Rnd + 1)
r = Round(r, 0)
Rand1To100 = r
End Function
Private Sub TestSort()
Dim v(1 To 4, 1 To 2) As String
v(1, 1) = "A"
v(1, 2) = "6"
v(2, 1) = "B"
v(2, 2) = "2"
v(3, 1) = "C"
v(3, 2) = "2"
v(4, 1) = "D"
v(4, 2) = "4"
Call NonRepeatSort(v)
End Sub
And you'll need this class module:
' * Class module named Element
Private pName As String
Private pTotal As Long
Private pUsed As Long
Private FrequencyCoefficient As Long ' Obsolete?
' Name
Public Property Get Name() As String
Name = pName
End Property
Public Property Let SetName(s As String)
pName = s
End Property
' Total
Public Property Get Total() As Long
Total = pTotal
End Property
Public Property Let SetTotal(t As Long)
pTotal = t
End Property
' Used
Public Property Get Used() As Long
Used = pUsed
End Property
Public Sub IncrementUsed()
pUsed = pUsed + 1
End Sub
' Freq coefficient
Public Property Get Freq(f As Long) As Double
' Where f is the total number of elements
'Freq = FrequencyCoefficient
Freq = Round((Me.Total / f) * 100, 5)
End Property
Private Property Let SetFreq(f As Long)
' Obsolete?
' Where f is the total number of elements
FrequencyCoefficient = Round((Me.Total / f) * 100)
End Property
' Used freq - internal
Public Property Get UsedFreqI() As Long
If Me.Used > 0 Then
UsedFreqI = Round((Me.Used / Me.Total) * 100)
'Debug.Print "UF: " & UsedFreqI
Else
UsedFreqI = 0
End If
End Property
' Used freq - external
Public Property Get UsedFreqE(f As Long) As Long
If Me.Used > 0 Then
UsedFreq = Round((Me.Used / f) * 100)
Else
UsedFreq = 0
End If
End Property
I looked for the answer of my problem in all topics discussed on this platform such as Compare two Sheet and find differences, Macro to compare two worksheets & highlights differences and so on ... but I did not found what I was looking for.
My question is ; is there a possibility to compare two excel worksheets with a different layout as below? I'm willing to compare an historical worksheets versus a new worksheets and display in a third worksheet what was on the new worksheet that does not exist in the historical e.g :
I hope you will understand my question and be able to help me on this topic. I already have a code which compare two worksheet and show the difference but it's not enough for my problem.
Option Explicit
Sub CompareIt()
Dim ar As Variant
Dim arr As Variant
Dim Var As Variant
Dim v()
Dim i As Long
Dim n As Long
Dim j As Long
Dim str As String
ar = Sheet1.Cells(10, 1).CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
ReDim v(1 To UBound(ar, 2))
For i = 2 To UBound(ar, 1)
For n = 1 To UBound(ar, 2)
str = str & Chr(2) & ar(i, n)
v(n) = ar(i, n)
Next
.Item(str) = v: str = ""
Next
ar = Sheet2.Cells(10, 1).CurrentRegion.Resize(, UBound(v)).Value
For i = 2 To UBound(ar, 1)
For n = 1 To UBound(ar, 2)
str = str & Chr(2) & ar(i, n)
v(n) = ar(i, n)
Next
If .exists(str) Then
.Item(str) = Empty
Else
.Item(str) = v
End If
str = ""
Next
For Each arr In .keys
If IsEmpty(.Item(arr)) Then .Remove arr
Next
Var = .items: j = .Count
End With
With Sheet3.Range("a1").Resize(, UBound(ar, 2))
.CurrentRegion.ClearContents
.Value = ar
If j > 0 Then
.Offset(1).Resize(j).Value = Application.Transpose(Application.Transpose(Var))
End If
End With
End Sub
Thanks in advance
This is my current implementation using bits:
Function Array_PowerSet(Self)
Array_PowerSet = Array()
PowerSetUpperBound = -1
For Combination = 1 To 2 ^ (UBound(Self) - LBound(Self)) ' I don't want the null set
Subset = Array()
SubsetUpperBound = -1
For NthBit = 0 To Int(WorksheetFunction.Log(Combination, 2))
If Combination And 2 ^ NthBit Then
SubsetUpperBound = SubsetUpperBound + 1
ReDim Preserve Self(0 To SubsetUpperBound)
Subset(SubsetUpperBound) = Self(NthBit)
End If
Next
PowerSetUpperBound = PowerSetUpperBound + 1
ReDim Preserve Array_PowerSet(0 To PowerSetUpperBound)
Array_PowerSet(PowerSetUpperBound) = Subset
Next
End Function
Please ignore the abuse of Variants. Array_Push and Array_Size should be self-explanatory.
Previously, I was generating a binary string for each combination, but that involved calling another function which wasn't very efficient.
Aside from using less Variants and moving external function calls inside, is there any way I can make this more efficient?
EDIT: Here's a fully independent version.
Function Array_PowerSet(Self As Variant) As Variant
Dim PowerSet() As Variant, PowerSetIndex As Long, Size As Long, Combination As Long, NthBit As Long
PowerSetIndex = -1: Size = UBound(Self) - LBound(Self) + 1
ReDim PowerSet(0 To 2 ^ Size - 2) ' Don't want null set
For Combination = 1 To 2 ^ Size - 1
Dim Subset() As Variant, SubsetIndex As Long: SubsetIndex = -1
For NthBit = 0 To Int(WorksheetFunction.Log(Combination, 2))
If Combination And 2 ^ NthBit Then
SubsetIndex = SubsetIndex + 1
ReDim Preserve Subset(0 To SubsetIndex)
Subset(SubsetIndex) = Self(NthBit)
End If
Next
PowerSetIndex = PowerSetIndex + 1
PowerSet(PowerSetIndex) = Subset
Next
Array_PowerSet = PowerSet
End Function
And a test:
Dim Input_() As Variant, Output_() As Variant, Subset As Variant, Value As Variant
Input_ = Array(1, 2, 3)
Output_ = Array_PowerSet(Input_)
For Each Subset In Output_
Dim StringRep As String: StringRep = "{"
For Each Value In Subset
StringRep = StringRep & Value & ", "
Next
Debug.Print Left$(StringRep, Len(StringRep) - 2) & "}"
Next
Since the number of subsets grows exponentially, no algorithm is truly efficient, although there is room for improvement in what you are doing:
ReDim Preserve, when used to extend an array by a single item, is inefficient since it involves creating a new array with 1 more space and then copying the old elements to the new array. It is better to pre-allocate enough space and then trim it down to size:
Function PowerSet(Items As Variant) As Variant
'assumes that Items is a 0-based array
'returns a 0-based jagged array of subsets of Items
'where each subset is a 0-based array
Dim PS As Variant
Dim i As Long, j As Long, k As Long, n As Long
Dim subset As Variant
n = 1 + UBound(Items) 'cardinality of the base set
ReDim PS(0 To 2 ^ n - 2)
For i = 1 To 2 ^ n - 1
subset = Array()
ReDim subset(0 To n - 1)
k = -1 'will be highest used index of the subset
For j = 0 To n - 1
If i And 2 ^ j Then
k = k + 1
subset(k) = Items(j)
End If
Next j
ReDim Preserve subset(0 To k)
PS(i - 1) = subset
Next i
PowerSet = PS
End Function
A test function:
Sub test()
Dim stuff As Variant, subsets As Variant
Dim i As Long
stuff = Array("a", "b", "c", "d")
subsets = PowerSet(stuff)
For i = LBound(subsets) To UBound(subsets)
Cells(i + 1, 1).Value = "{" & Join(subsets(i), ",") & "}"
Next i
End Sub
Using collections to build your sets is an option...
Function Generator()
Dim Arr() As Variant: Arr = Array(1, 2, 3, 4)
Dim PSCol As Collection: Set PSCol = PowerSetCol(Arr)
Dim SubSet As Collection, SubSetStr As String
For i = 1 To PSCol.Count
Set SubSet = PSCol.Item(i)
SubSetStr = "{"
For j = 1 To SubSet.Count
SubSetStr = SubSetStr & SubSet.Item(j) & IIf(j = SubSet.Count, "", ", ")
Next j
SubSetStr = SubSetStr & "}"
Debug.Print SubSetStr
Next i
End Function
Function PowerSetCol(Arr As Variant) As Collection
Dim n As Long, i As Long
Dim Temp As New Collection, SubSet As Collection
For i = 1 To 2 ^ (UBound(Arr) + 1) - 1
Set SubSet = New Collection
For n = 0 To UBound(Arr)
If i And 2 ^ n Then SubSet.Add Arr(n)
Next n
Temp.Add SubSet
Next i
Set PowerSetCol = Temp
End Function
******* EDIT ********
Apparently accessing collections through index is more intensive than enumerating through the items. Also; you can't use join directly as stated by #John Coleman but a single line function can be used in it's place.
Hopefully the code below is a more optimal solution
Function Generator()
Dim Arr() As Variant: Arr = Array(1, 2, 3, 4)
Dim PSColl As Collection: Set PSColl = PowerSetColl(Arr)
Dim Str As String, Coll As Collection, Item As Variant
For Each Coll In PSColl
Str = ""
For Each Item In Coll
Str = strJoin(", ", Str, CStr(Item))
Next Item
Debug.Print "{" & Str & "}"
Next Coll
End Function
Function PowerSetColl(Arr As Variant) As Collection
Dim Temp As New Collection, SubSet As Collection
Dim n As Long, i As Long
For i = 1 To 2 ^ (UBound(Arr) + 1) - 1
Set SubSet = New Collection
For n = 0 To UBound(Arr)
If i And 2 ^ n Then SubSet.Add Arr(n)
Next n
Temp.Add SubSet
Next i
Set PowerSetColl = Temp
End Function
Function strJoin(Delimiter As String, Optional Str1 As String, Optional Str2 As String) As String
strJoin = IIf(IsMissing(Str1) Or Str1 = "", Str2, IIf(IsMissing(Str2) Or Str2 = "", Str1, Str1 & Delimiter & Str2))
End Function
I would really appreciate it if someone could give me some help with this.
I am quite familiar with vba and I can write simple code and also customise code from others. I have written /customised/copied several pieces of vba code to do the following (where copied source is acknowledged):
Select 2 different csv files which represent 2 matrixes of same columns and same rows.
Multiply each respective cells from the matrices.
Return results.
Unfortunately I cannot seem to be able to get this to run.
Any idea what I have not done correctly?
Please see the code below. Thanks so much.
Code changed from previous version
Public Sub doIt()
Dim sourceFile As String
Dim destinationFile As String
Dim data As Variant
Dim result As Variant
Dim sourceFile2 As String
Dim datarain As Variant
sourceFile = "C:\file1.csv"
sourceFile2 = "C:\file2.csv"
destinationFile = "C:\file3.txt"
data = getDataFromFile(sourceFile, ",")
datarain = getDataFromFile(sourceFile2, ",")
If Not isArrayEmpty(data) Then
result = MMULT2_FUNC(data, datarain)
writeToCsv result, destinationFile, ","
Else
MsgBox ("Empty file")
End If
End Sub
Function MMULT2_FUNC(ByRef ADATA_RNG As Variant, _
ByRef BDATA_RNG As Variant)
Dim i As Long
Dim j As Long
Dim k As Long
Dim ANROWS As Long
Dim BNROWS As Long
Dim ANCOLUMNS As Long
Dim BNCOLUMNS As Long
Dim ADATA_MATRIX As Variant
Dim BDATA_MATRIX As Variant
Dim TEMP_MATRIX As Variant
On Error GoTo ERROR_LABEL
ADATA_MATRIX = ADATA_RNG
BDATA_MATRIX = BDATA_RNG
ANROWS = UBound(ADATA_MATRIX, 1)
BNROWS = UBound(BDATA_MATRIX, 1)
ANCOLUMNS = UBound(ADATA_MATRIX, 2)
BNCOLUMNS = UBound(BDATA_MATRIX, 2)
If ANCOLUMNS <> BNROWS Then: GoTo ERROR_LABEL
ReDim TEMP_MATRIX(1 To ANROWS, 1 To BNCOLUMNS)
For i = 1 To ANROWS
For j = 1 To BNCOLUMNS
TEMP_MATRIX(i, j) = 0
For k = 1 To ANCOLUMNS
TEMP_MATRIX(i, j) = TEMP_MATRIX(i, j) + ADATA_MATRIX(i, k) * _
BDATA_MATRIX(k, j)
Next k
Next j
Next i
MMULT2_FUNC = TEMP_MATRIX
Exit Function
ERROR_LABEL:
MMULT2_FUNC = Err.Number
End Function
Public Sub writeToCsv(parData As Variant, parFileName As String, parDelimiter As String)
If getArrayNumberOfDimensions(parData) <> 2 Then Exit Sub
Dim i As Long
Dim j As Long
Dim FileNum As Long
Dim locLine As String
Dim locCsvString As String
FileNum = FreeFile
If Dir(parFileName) <> "" Then Kill (parFileName)
Open parFileName For Binary Lock Read Write As #FileNum
For i = LBound(parData, 1) To UBound(parData, 1)
locLine = ""
For j = LBound(parData, 2) To UBound(parData, 2)
If IsError(parData(i, j)) Then
locLine = locLine & "#N/A" & parDelimiter
Else
locLine = locLine & parData(i, j) & parDelimiter
End If
Next j
locLine = Left(locLine, Len(locLine) - 1)
If i <> UBound(parData, 1) Then locLine = locLine & vbCrLf
Put #FileNum, , locLine
Next i
error_handler:
Close #FileNum
End Sub
Public Function isArrayEmpty(parArray As Variant) As Boolean
'Returns false if not an array or dynamic array that has not been initialised (ReDim) or has been erased (Erase)
If IsArray(parArray) = False Then isArrayEmpty = True
On Error Resume Next
If UBound(parArray) < LBound(parArray) Then isArrayEmpty = True: Exit Function Else: isArrayEmpty = False
End Function
Public Function getArrayNumberOfDimensions(parArray As Variant) As Long
'Returns the number of dimension of an array - 0 for an empty array.
Dim i As Long
Dim errorCheck As Long
If isArrayEmpty(parArray) Then Exit Function 'returns 0
On Error GoTo FinalDimension
'Visual Basic for Applications arrays can have up to 60000 dimensions
For i = 1 To 60001
errorCheck = LBound(parArray, i)
Next i
'Not supposed to happen
getArrayNumberOfDimensions = 0
Exit Function
FinalDimension:
getArrayNumberOfDimensions = i - 1
End Function
Private Function getDataFromFile(parFileName As String, parDelimiter As String, Optional parExcludeCharacter As String = "") As Variant
'parFileName is supposed to be a delimited file (csv...)
'parDelimiter is the delimiter, "," for example in a comma delimited file
'Returns an empty array if file is empty or can't be opened
'number of columns based on the line with the largest number of columns, not on the first line
'parExcludeCharacter: sometimes csv files have quotes around strings: "XXX" - if parExcludeCharacter = """" then removes the quotes
Dim locLinesList() As Variant
Dim locData As Variant
Dim i As Long
Dim j As Long
Dim locNumRows As Long
Dim locNumCols As Long
Dim fso As Variant
Dim ts As Variant
Const REDIM_STEP = 10000
Set fso = CreateObject("Scripting.FileSystemObject")
On Error GoTo error_open_file
Set ts = fso.OpenTextFile(parFileName)
On Error GoTo unhandled_error
'Counts the number of lines and the largest number of columns
ReDim locLinesList(1 To 1) As Variant
i = 0
Do While Not ts.AtEndOfStream
If i Mod REDIM_STEP = 0 Then
ReDim Preserve locLinesList(1 To UBound(locLinesList, 1) + REDIM_STEP) As Variant
End If
locLinesList(i + 1) = Split(ts.ReadLine, parDelimiter)
j = UBound(locLinesList(i + 1), 1) 'number of columns
If locNumCols < j Then locNumCols = j
If j = 13 Then
j = j
End If
i = i + 1
Loop
ts.Close
locNumRows = i
If locNumRows = 0 Then Exit Function 'Empty file
ReDim locData(1 To locNumRows, 1 To locNumCols + 1) As Variant
'Copies the file into an array
If parExcludeCharacter <> "" Then
For i = 1 To locNumRows
For j = 0 To UBound(locLinesList(i), 1)
If Left(locLinesList(i)(j), 1) = parExcludeCharacter Then
If Right(locLinesList(i)(j), 1) = parExcludeCharacter Then
locLinesList(i)(j) = Mid(locLinesList(i)(j), 2, Len(locLinesList(i)(j)) - 2) 'If locTempArray = "", Mid returns ""
Else
locLinesList(i)(j) = Right(locLinesList(i)(j), Len(locLinesList(i)(j)) - 1)
End If
ElseIf Right(locLinesList(i)(j), 1) = parExcludeCharacter Then
locLinesList(i)(j) = Left(locLinesList(i)(j), Len(locLinesList(i)(j)) - 1)
End If
locData(i, j + 1) = locLinesList(i)(j)
Next j
Next i
Else
For i = 1 To locNumRows
For j = 0 To UBound(locLinesList(i), 1)
locData(i, j + 1) = locLinesList(i)(j)
Next j
Next i
End If
getDataFromFile = locData
Exit Function
error_open_file: 'returns empty variant
unhandled_error: 'returns empty variant
End Function
Despite my personal impression that your code can be improved in some instances, it syntactically executes here with no problem (on small matrices).
My test data
1,2,3 2,3,4 20,26,32
2,3,4 X 3,4,5 = 29,38,47
3,4,5 4,5,6 38,50,62
The result is neatly written to a CSV.
Only obvious problem (here on Win 7 !) is that Sub writeToCsv -> Open parFileName ... fails due to lack of write permissions into the root directory. This might be not a problem on XP.
On a different token, I have the impression the code can be improved, but I may not understand the rationale behind some parts of your code.
examples
Function MMULT2_FUNC(ByRef ADATA_RNG As Variant, ByRef BDATA_RNG As Variant) ' missing type of result
Private Function getDataFromFile(...)
...
If j = 13 Then
j = j
End If ' whow ... if j <> 13 then j again equals j ;-)
finding upper and lower bounds of the matrices on input as well as on output could be simplified by large ...
Thank you all for your help. The reason why my code was not printing results was that I had this:If ANCOLUMNS <> BNROWS Then: GoTo ERROR_LABEL. At the same time, I was using two matrices of 70*120, so it constantly exited the function as I had programmed it to do!!Corrected it all and worked fine. Thanks a lot for your help
This might be a little tricky, even with VBA...
I have comma separated lists in cells based on start times over 5 minutes intervals but I need to remove times that are only 5 apart.
The numbers are text, not time at this point. For example, one list would be 2210, 2215, 2225, 2230, 2240 (the start times).
In this case, 2215 and 2230 should be removed but I also need to remove the opposite numbers (i.e.,2210 and 2225) in other cases (the end times).
Someone helped me with my specs:
A cell contains times: t(1), t(2), t(3), ... t(n). Starting at time t(1), each value in the list is examined. If t(x) is less than 6 minutes after t(x-1) delete t(x) and renumber t(x+1) to t(n).
Input:
2210, 2215, 2225, 2230, 2240
Output:
column1: 2210
column2: 2240
This does what I think you require.
Option Explicit
Sub DeleteSelectedTimes()
Dim RowCrnt As Long
RowCrnt = 2
Do While Cells(RowCrnt, 1).Value <> ""
Cells(RowCrnt, 1).Value = ProcessSingleCell(Cells(RowCrnt, 1).Value, 1)
Cells(RowCrnt, 2).Value = ProcessSingleCell(Cells(RowCrnt, 2).Value, -1)
RowCrnt = RowCrnt + 1
Loop
End Sub
Function ProcessSingleCell(ByVal CellValue As String, ByVal StepFactor As Long) As String
Dim CellList() As String
Dim CellListCrntStg As String
Dim CellListCrntNum As Long
Dim InxCrnt As Long
Dim InxEnd As Long
Dim InxStart As Long
Dim TimeCrnt As Long ' Time in minutes
Dim TimeLast As Long ' Time in minutes
CellList = Split(CellValue, ",")
If StepFactor = 1 Then
InxStart = LBound(CellList)
InxEnd = UBound(CellList)
Else
InxStart = UBound(CellList)
InxEnd = LBound(CellList)
End If
CellListCrntStg = Trim(CellList(InxStart))
If (Not IsNumeric(CellListCrntStg)) Or InStr(CellListCrntStg, ".") <> 0 Then
' Either this sub-value is not numeric or if contains a decimal point
' Either way it cannot be a time.
ProcessSingleCell = CellValue
Exit Function
End If
CellListCrntNum = Val(CellListCrntStg)
If CellListCrntNum < 0 Or CellListCrntNum > 2359 Then
' This value is not a time formatted as hhmm
ProcessSingleCell = CellValue
Exit Function
End If
TimeLast = 60 * (CellListCrntNum \ 100) + (CellListCrntNum Mod 100)
For InxCrnt = InxStart + StepFactor To InxEnd Step StepFactor
CellListCrntStg = Trim(CellList(InxCrnt))
If (Not IsNumeric(CellListCrntStg)) Or InStr(CellListCrntStg, ".") <> 0 Then
' Either this sub-value is not numeric or if contains a decimal point
' Either way it cannot be a time.
ProcessSingleCell = CellValue
Exit Function
End If
CellListCrntNum = Val(CellListCrntStg)
If CellListCrntNum < 0 Or CellListCrntNum > 2359 Then
' This value is not a time formatted as hhmm
ProcessSingleCell = CellValue
Exit Function
End If
TimeCrnt = 60 * (CellListCrntNum \ 100) + (CellListCrntNum Mod 100)
If Abs(TimeCrnt - TimeLast) < 6 Then
' Delete unwanted time from list
CellList(InxCrnt) = ""
Else
' Current time becomes Last time for next loop
TimeLast = TimeCrnt
End If
Next
CellValue = Join(CellList, ",")
If Left(CellValue, 1) = "," Then
CellValue = Mid(CellValue, 2)
CellValue = Trim(CellValue)
End If
Do While InStr(CellValue, ",,") <> 0
CellValue = Replace(CellValue, ",,", ",")
Loop
ProcessSingleCell = CellValue
End Function
Explanation
Sorry for the lack of instructions in the first version. I assumed this question was more about the technique for manipulating the data than about VBA.
DeleteSelectedTimes operates on the active worksheet. It would be easy to change to work on a specific worksheet or a range of worksheets if that is what you require.
DeleteSelectedTimes ignores the first row which I assume contains column headings. Certainly my test worksheet has headings in row 1. It then processes columns A and B of every row until it reaches a row with an empty column A.
ProcessSingleCell has two parameters: a string and a direction. DeleteSelectedTimes uses the direction so values in column A are processed left to right while values in column B are processed right to left.
I assume the #Value error is because ProcessSingleCell does not check that the string is of the format "number,number,number". I have changed ProcessSingleCell so if the string is not of this format, it does change the string.
I have no clear idea of what you do or do not know so come back with more questions as necessary.
Still not clear on your exact requirements, but this might help get you started....
Sub Tester()
Dim arr
Dim out As String, x As Integer, c As Range
Dim n1 As Long, n2 As Long
For Each c In ActiveSheet.Range("A1:A10")
If InStr(c.Value, ",") > 0 Then
arr = Split(c.Value, ",")
x = LBound(arr)
out = ""
Do
n1 = CLng(Trim(arr(x)))
n2 = CLng(Trim(arr(x + 1)))
'here's where your requirements get unclear...
out = out & IIf(Len(out) > 0, ", ", "")
If n2 - n1 <= 5 Then
out = out & n1 'skip second number
x = x + 2
Else
out = out & n1 & ", " & n2 'both
x = x + 1
End If
Loop While x <= UBound(arr) - 1
'pick up any last number
If x = UBound(arr) Then
out = out & IIf(Len(out) > 0, ", ", "") & arr(x)
End If
c.Offset(0, 1).Value = out
End If
Next c
End Sub
Obviously many ways to skin this cat ... I like to use collections for this sort of thing:
Private Sub PareDownList()
Dim sList As String: sList = ActiveCell ' take list from active cell
Dim vList As Variant: vList = Split(sList, ",") ' convert to variant array
' load from var array into collection
Dim cList As New Collection
Dim i As Long
For i = 0 To UBound(vList): cList.Add (Trim(vList(i))): Next
' loop over collection removing unwanted entries
' (in reverse order, since we're removing items)
For i = cList.Count To 2 Step -1
If cList(i) - cList(i - 1) = 5 Then cList.Remove (i)
Next i
' loop to put remaining items back into a string fld
sList = cList(1)
For i = 2 To cList.Count
sList = sList + "," + cList(i)
Next i
' write the new string to the cell under the activecell
ActiveCell.Offset(1) = "'" + sList ' lead quote to ensure output cell = str type
End Sub
' If activecell contains: "2210, 2215, 2225, 2230, 2240"
' the cell below will get: "2210,2225,2240"
Note: this sample code should be enhanced w some extra validation & checking (e.g. as written assumes all good int values sep by commas & relies in implicit str to int conversions). Also as written will convert "2210, 2215, 2220, 2225, 2230, 2240" into "2210, 2040" - you'll need to tweak the loop, loop ctr when removing an item if that's not what you want.