I'm very new to using VBA, and I am trying to create a code with these rules (Please see image for context):
If Column B cell has the text "GBP", then go across to the Adjacent cell in Column C. If the first 2 letters of the C cell begins with RB, then post the text "Royal Bank of Scotland" in an adjacent Cell D, if the first 2 letters are HC, then post the text "Corporate" in an adjacent Cell D instead.
If Column B cell has the text "USD", then go across to the Adjacent cell in Column C. If the first 2 letters of the C cell begins with JP, then post the text "JPMorgan" in an adjacent Cell D, if the first 2 letters are BO, then post the text "Bank of America" in an adjacent Cell D instead.
I can do all this manually using excel formulas, however, there's quite a lot of information and Im trying to figure out an automated way of doing this.
Problem image
The following code should do. The code assumes that the data is in a sheet named "Data", starting in row 3, and the desired replacements are in another sheet named "Replacements". In this last sheet, starting in the firt row, you must fill column A with Currency (GBP or USD), column B with the two letters code (RB, HC and so on) and column C with the desired substitution (Bank of America, etc.). In your current example, there should be 8 rows of data (the 4 lines that appear in lines 26-29, once for GBP and again for USD).
Sub ReplaceBankName()
Dim sReplacementArray() As Variant
Dim lLastRowReplacements As Integer
Dim lLastRowData As Integer
Dim r As Long, c As Long
Dim ValToFind1 As String
Dim ValToFind2 As String
lLastRowReplacements = Worksheets("Replacements").Cells(Rows.Count, 1).End(xlUp).Row
lLastRowData = Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
'Create an array with replacement data
For i = 1 To lLastRowReplacements
ReDim Preserve sReplacementArray(1 To 3, 1 To i)
sReplacementArray(1, i) = Worksheets("Replacements").Cells(i, 1).Value
sReplacementArray(2, i) = Worksheets("Replacements").Cells(i, 2).Value
sReplacementArray(3, i) = Worksheets("Replacements").Cells(i, 3).Value
Next
'Now array has replacemente data
'if you wish to know array elements, uncomment next three lines
'For c = 1 To UBound(sReplacementArray, 2)
' MsgBox "Currency: " & sReplacementArray(1, c) & " - BankCode: " & sReplacementArray(2, c) & " - Replacement: " & sReplacementArray(3, c)
' Next c
For i = 3 To lLastRowData 'Scan all rows with data
'Get values from column B (ValToFind1) and C (ValToFind2, first two letters only)
ValToFind1 = Worksheets("Data").Cells(i, 2).Value
ValToFind2 = Left(Worksheets("Data").Cells(i, 3).Value, 2)
'Find those to values in the array, and write the replacement in column D
For r = 1 To UBound(sReplacementArray, 1)
For c = 1 To UBound(sReplacementArray, 2)
If (sReplacementArray(1, c) = ValToFind1 And sReplacementArray(2, c) = ValToFind2) Then
Worksheets("Data").Cells(i, 4).Value = sReplacementArray(3, c)
End If
Next c
Next r
Next i
End Sub
I would prefer a formula, but since you asked for VBA:
Sub marine()
Dim ws As Worksheet
Dim i As Long
Set ws = ActiveSheet
With ws
For i = 4 To 20
Select Case Left(.Cells(i, 3), 3)
Case "RBS"
.Cells(i, 4) = "Royal Bank of Scotland"
Case "HCN"
.Cells(i, 4) = "Corporate"
Case "JPM"
.Cells(i, 4) = "JPMorgan"
Case "BOM"
.Cells(i, 4) = "Bank of America"
Case Else
MsgBox "This Bank does not exist :-D"
End Select
Next i
End With
End Sub
In D4, Apply the below formula and drag down
Note: As per the Context/Example, i have taken the first three characters in C column
=IF(AND(B4="GBP",LEFT(C4,3)="RBS"),"RoyalBankofScotland",IF(AND(B4="GBP",LEFT(C4,3)="HCN"),"Corporate",IF(AND(B4="GBP",LEFT(C4,3)="JPM"),"JP Morgan",IF(AND(B4="GBP",LEFT(C4,3)="BOM"),"Bank of America",IF(AND(B4="USD",LEFT(C4,3)="RBS"),"RoyalBankofScotland",IF(AND(B4="USD",LEFT(C4,3)="HCN"),"Corporate",IF(AND(B4="USD",LEFT(C4,3)="JPM"),"JP Morgan",IF(AND(B4="USD",LEFT(C4,3)="BOM"),"Bank of America","Not Available"))))))))
Related
I have the following task:
There are fields in my document, the combination of which needs to be compared, and if they are the same, another field on the same rows need to be updated.
So far, I add the values in arrays (skipping the first row as header, thus iNum = 2) with select statements per column and concatenate them per row for the comparison.
Dim conc As Range 'Concatenated fields
Dim iconc() As Variant
ReDim iconc(UBound(iMatn) - 1, 1)
For iNum = 2 To UBound(iMatn)
iconc(iNum - 1, 1) = iMatn(iNum, 1) & iVendr(iNum, 1) & iInd1(iNum, 1) & iInd2(iNum, 1) 'Current concatenation
Select Case iNum - 1
Case 2: 'Compare two records
If iconc(iNum - 2, 1) = iconc(iNum - 1, 1) Then 'Compare first and second records
'Execute code to update the two fields from Extra field column
End If
Case 3: 'Compare three records
If AllSame(iconc(iNum - 3, 1), iconc(iNum - 2, 1), iconc(iNum - 1, 1)) Then
'Execute code to update the three fields from Extra field column
End If
I go through each value of the concatenation and compare if its the same as the previous ones with Case statement (I don't expect more than 4 or 5 to be the same, even though there could be a couple hundred of lines).
Thus I face two issues:
If there are 3 equal values, for example, the code first jumps to the case for 2. How can I make it so that it skips to the maximum value?
It needs to resume checking after the rows that were already checked. E.g. if the first two are the same, the code should start checking from the third one; basically to start at from the line after the last of any duplicate ones that are located.
Example
Image: the code needs to return that there are 3 equal rows (lines 2 to 4), update the respective cells on the "Extra field" column, proceed further (from line 5), return that there are 2 equal rows (lines 6 and 7), update the same as above again, proceed further (from line 8) etc.
Any help will be highly appreciated as I am stuck with this problem.
Thank you all.
To determine how many are in each group, in order to decide how you will update the extra fields column, I would use a Dictionary & Collection object.
eg:
'Set reference to Microsoft Scripting Runtime
' (or use late-binding)
Option Explicit
Sub due()
Dim myDict As Dictionary, col As Collection
Dim i As Long, v As Variant
Dim sKey As String
Dim rTable As Range
Dim vTable As Variant, vResults As Variant
'there are more robust methods of selecting the table range
'depending on your actual layout
'And code will also make a difference if the original range includes
' or does not include the "Extra Field" Column
' Code below assumes it is NOT included in original data
Set rTable = ThisWorkbook.Worksheets("sheet2").Cells(1, 1).CurrentRegion
vTable = rTable
Set myDict = New Dictionary
For i = 2 To UBound(vTable)
sKey = vTable(i, 1) & vTable(i, 2) & vTable(i, 3) & vTable(i, 4)
Set col = New Collection
If Not myDict.Exists(sKey) Then
col.Add Item:=WorksheetFunction.Index(vTable, i, 0)
myDict.Add Key:=sKey, Item:=col
Else
myDict(sKey).Add Item:=WorksheetFunction.Index(vTable, i, 0)
End If
Next i
For Each v In myDict.Keys
Select Case myDict(v).Count
Case 2
Debug.Print v, "Do update for two rows"
Case 3
Debug.Print v, "Do update for three rows"
Case Else
Debug.Print v, "No update needed"
End Select
Next v
End Sub
=>
1234V22341212 Do update for three rows
1234v22351215 No update needed
2234v22361515 Do update for two rows
2234v22361311 No update needed
Although, I would probably use Power Query (available in Windows Excel 2010+ and 365) which can easily group by the four columns and return a count. You can then add a new column depending on that count.
Not knowing the nature of your updating Extra Field and the difference between what happens for 2, 3, 4, ... the same, it is not possible to supply any code for that purpose.
In general, you would
expand the array for each dictionary item
Add the extra column if it's not already there
Do the update
Add that to a pre-dimensioned results array
Write the results array back to the worksheet
Note that this method of working with VBA arrays will execute an order of magnitude faster than doing repeated worksheet accessing, but the code is longer.
If you use a look ahead to the next row (rather than look behind) you can determine the end of the group and process accordingly.
Option Explicit
Sub CompareRows()
Dim ws As Worksheet, ar, arExtra
Dim lastrow As Long, n As Long, i As Long, k As Long
Dim s As String, sNext As String, rng As Range, iColor As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
ar = .Range("A1:D1").Resize(lastrow)
n = 1
For i = 1 To UBound(ar)
' look ahead to next line
If i = UBound(ar) Then
sNext = ""
Else
sNext = ar(i + 1, 1) & "_" & ar(i + 1, 2) & _
"_" & ar(i + 1, 3) & "_" & ar(i + 1, 4)
End If
If i > 1 Then ' skip header
' increment count if matched
If sNext = s Then
n = n + 1
' process group using counter n
Else
If n >= 2 Then
' first row of group
Set rng = .Cells(i, "E").Offset(1 - n)
If n >= 3 Then
iColor = rgb(128, 255, 128) ' green
Else
iColor = rgb(255, 255, 128) ' yellow
End If
'code to update n rows in Extra column
rng.Resize(n).Value = n
rng.Offset(, -4).Resize(n, 5).Interior.color = iColor
k = k + 1 ' group count
End If
n = 1
End If
End If
s = sNext
Next
End With
MsgBox k & " groups found", vbInformation
End Sub
I've spent hours trying to find out how to join returned values from a named range, but the result is a
run-time error 32 - Type mismatch.
As a newbie I'm still struggling with arrays, so maybe I've overlooked some detail. Thank you for helping me out.
Example: (B1)Benzine, (B2)Diesel, (B3)Hybride -> (E1)Gasoline, (E2)Diesel, (E3)Hybrid
This is the named range:
Another example (to be more clear):
Example 2: (B1)Benzine, (B3)Hybride -> (E1)Gasoline, (E3)Hybrid
Option Explicit
Sub splitter()
Dim i As Long
Dim w As Long
'Dim oWB As Workbook
Dim oWS As Worksheet
Dim oWS9 As Worksheet
Dim rngMOTOR As Range
Dim rngMOTOR2 As Range
Dim arrMOTOR() As Variant
Dim LastRow As Long
'Set oWB = Workbooks("BRONBESTAND.xlsm")
Set oWS = Sheets("ONDERDELEN")
Set oWS9 = Sheets("MOTOR") '5 columns: 1 Short & LONG + 1 NL + 3 Languages !!!!! WARNING
LastRow = oWS.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow 'Starting below headers
Set rngMOTOR = oWS.Cells(i, "M") 'MOTOR ...
Set rngMOTOR2 = oWS9.Range("MOTOR") 'MOTOR2: MOTOR - Bronbestand arrPOS = rngPOS2.Value
arrMOTOR = rngMOTOR2.Value
'*********
Dim txt As String
Dim j As Integer
Dim Splitted As Variant
Dim arrMOTORall As Variant
Dim arrMOTORsplit As Variant
Dim Motor3 As String
txt = oWS.Cells(i, "M") 'MOTOR ...
Debug.Print ("txt : ") & i & ": "; txt
If Not IsEmpty(txt) Then
Splitted = Split(txt, ", ")
For j = 0 To UBound(Splitted)
Cells(1, j + 1).Value = Splitted(j)
Debug.Print (" ---> Splitted: ") & Splitted(j)
'**** INSERT *****
For w = LBound(arrMOTOR) To UBound(arrMOTOR)
If arrMOTOR(w, 1) = Splitted(j) Then 'EX: B - Benzine
arrMOTORsplit = (arrMOTOR(w, 4)) '(arrMOTOR(y, 2)) -> 1=SHORT+LONG , 2=NL, 3=FR, 4=EN
Debug.Print (" ---> arrMOTORsplit: ") & i & ": " & arrMOTORsplit
'**** JOIN ****
arrMOTORall = Join(arrMOTORsplit, ", ")
Debug.Print ("arrMOTORall: ") & arrMOTORall
End If
Next w
Next j
End If
Next i
End Sub
Get comma separated strings for each column in named range
I didn't analyze your code, but this should work to receive the first three values joined
"Benzine, Diesel, Hybride" ' e.g. from first column
or
"Gasoline, Diesel, Hybrid" ' e.g. from the fourth column
from a named range "Motor" via the Application.Index function.
Notes
The parameter 0 in this Index function indicates to not choose a specific row, the Parameter ColNo chooses each of your columns in a Loop. A subsequent transposition allows to change the 2 dimensioned array values to a 1-dim array. The Join function needs a 1-dim array and concatenates the chosen column items therein.
Hint: The following sample code uses a fully qualified range reference assuming that you don't call the TestMe procedure from your Personal Macro Library. In the latter case you'd have to change references and workbook identification (not using ThisWorkbook!).
Example code
Option Explicit ' declaration head of your code module
Sub TestMe()
Dim v As Variant, ColNo As Long
' assign first three rows to variant 1-based 2-dim datafield array
v = ThisWorkbook.Worksheets("Motor").[Motor].Resize(3, 4) ' Named range value
' write comma separated list for each column
For ColNo = 1 To 4
Debug.Print Join(Application.Transpose(Application.Index(v, 0, ColNo)), ", ")
Next ColNo
End Sub
EDIT - Flexible Search in ANY ORDER to translate joined lists
This solution allows to return joined search words in any combination using the Application.Index function in an advanced way using row and column arrays as parameters. The main function getSplitters() creates a variant 2-dim array in only three steps without loops and redims and uses two language constants (Const DUTCH and Const ENGLISH).:
assigns data to variant 1-based 2-dim datafield array
gets only the selected rows based on comma separated string values
reduces the same array to Dutch and English columns
Calling Code
Due to your OP the calling code anylyzes all comma separated strings in Column M in your sheet "ONDERDELEN" as far as there are values in column A. This is made by passing these found string values to the main function getSplitters with an innovative approach to get results in only three steps without Loops (see function code below).
Translation is based on values in the named range Motor "B1:E4" in sheet "Motor" where rows comprise different sort of fuel with neighbouring columns for different languages (starting with Dutch in the first column and English in the fourth col).
Note that using VBA it is faster to loop through an array to get values than through a range.
Option Explicit ' declaration head of your code module
Const DUTCH As Integer = 1
Const ENGLISH As Integer = 4
Sub TranslateAnyFuelCombination()
' Purpose: returns comma separated lists in column "M" and translates from Dutch to English
' Example: "Benzine, Hybride, Diesel" (Dutch) gets to "Gasoline, Hybrid, Diesel" in English
Dim s As String
Dim oWS As Worksheet, i&, LastRow&, vMOTOR As Variant
Set oWS = Thisworkbook.Worksheets("ONDERDELEN") ' fully qualified reference
' Get last row of wanted data
LastRow = oWS.Range("A" & Rows.Count).End(xlUp).Row
vMOTOR = oWS.Range("M1:M" & LastRow)
For i = 2 To LastRow 'Starting below headers
Debug.Print getSplitters(vMOTOR(i, 1))
Next i
End Sub
Main function
Function getSplitters(ByVal sRows As String) As String
Dim i As Long, j As Long
Dim v As Variant, a As Variant
' [0] analyze selected rows string, e.g. "Benzine, Hybride, Diesel"
a = getRowAr(sRows) ' -> assign 1-dim Rows Array(1, 3, 2)
' [1] assign data to variant 1-based 2-dim datafield array
v = Application.Transpose(ThisWorkbook.Worksheets("Motor").[Motor]) ' Named range value
' [2] get only selected rows, e.g. 1st, 3rd and 2nd -> in free order (!) Benzine, Hybride, Diesel
v = Application.Transpose(Application.Index(v, _
Application.Evaluate("row(1:" & UBound(v, 2) & ")"), _
a)) ' transposed columns array = selected rows
' [3] reduce to Dutch and English columns
v = Application.Transpose(Application.Index(v, _
Application.Evaluate("row(1:" & (UBound(a) + 1) & ")"), _
Array(DUTCH, ENGLISH))) ' selected columns array (above array retransposed)
' [4] return concatenated strings
getSplitters = Join(Application.Transpose(Application.Transpose(Application.Index(v, 1, 0))), ", ") & " -> " & _
Join(Application.Transpose(Application.Transpose(Application.Index(v, 2, 0))), ", ")
End Function
Two helper functions
Function getRowAr(ByVal sList As String) As Variant
' Purpose: split comma separated list into 1-dim number array in FREE ORDER
' Example: "Benzine, Hybride, Diesel" -> Array(1, 3, 2)
Dim ar, i&
' change words in comma separated list to numbers
ar = Split(Replace(sList, " ", ""), ",")
For i = LBound(ar) To UBound(ar)
ar(i) = val(getNumber(ar(i))) ' change to numbers
Next i
getRowAr = ar ' return
End Function
Function getNumber(ByVal s As String) As Long
' Purpose: replaces dutch search words with corresponding row number
Dim arFuel
' get search words to 1-dim array
arFuel = Application.Index(ThisWorkbook.Worksheets("Motor").[Motor], 0, DUTCH)
' return corresponding number
getNumber = Application.Match(s, arFuel)
End Function
Addendum (Edit due to comment)
The above code works as intended if you are sure that the concatenated search words (or starting parts) actually match else an Error 13 is raised. You can solve this issue in two steps:
Insert an empty first row into your named range Motor (or fill it e.g. with ?, #N/A etc.)
Change the 2nd helper function as follows:
Edited function getNumber()
Function getNumber(ByVal s As String) As Long
' Purpose: replaces dutch search words with corresponding row number
Dim arFuel
' get search words to 1-dim array
arFuel = Application.Index(ThisWorkbook.Worksheets("Motor").[Motor], 0, DUTCH)
' return corresponding number
On Error Resume Next ' provide for not found case
getNumber = Application.Match(s, arFuel, 0) ' find only exact matches
If Err.Number <> 0 Then getNumber = 0 ' could be omitted in case of a zero return
End Function
With 2 arrays this is a possible solution:
Sub TestMe()
Dim inputString As String
Dim arrString As Variant
Dim arrResult As Variant
inputString = "Benzine, Diesel, Hybride"
arrString = Split(inputString, ",")
Dim total As Long: total = UBound(arrString)
ReDim arrResult(total)
Dim i As Long
For i = LBound(arrString) To UBound(arrString)
arrResult(total - i) = Trim(arrString(i))
Next i
Debug.Print Join(arrResult, " ,")
End Sub
However, there is a classic solution of this problem, reversing everything twice:
Sub TestMe()
Dim inputString As String
inputString = "Benzine, Diesel, Hybride"
inputString = StrReverse(inputString)
Dim arr As Variant: arr = Split(inputString, ",")
Dim i As Long
For i = LBound(arr) To UBound(arr)
arr(i) = Trim(StrReverse(arr(i)))
Next i
Debug.Print Join(arr, ", ")
End Sub
please bear with me as I'm very new to VBA, with prior experience primarily from Rhinoscript and other dedicated scripting options. The question is really very simple and I reckon someone can answer this very quickly, as I'm poor with arrays in VBA:
I have a spreadsheet where the objective is to import a number of values and text strings (resulting in some blanks) into e.g. A:L. This is done manually. I need to read these values into an array and then print them into a file so that each file row corresponds to a row of columns in the array. Currently I cannot seem to be able to convert the variant array into a string array (apparently necessary) and then join the subarrays into temporary arrays which are printed into the file. The following bit I've managed to scrape together results in a file output where each array value is on a single row, where as I'd like the contents of e.g. A1:L1 to be printed on single row.
Sub writerangetofile()
'Write data to a text file
'Declaring variables
Dim valarray() As Variant
Dim R As Long
Dim C As Long
'Set array as range
Sheet1.Activate
valarray() = Range("A1:L40")
'Setting the name and the path of text file based on workbook path
sFName = ThisWorkbook.Path & "\Output.txt"
'Get an unused file number
intFNumber = FreeFile
'Create a new file (or overwrite an existing one)
Open sFName For Output As #intFNumber
For R = 1 To UBound(valarray, 1) ' First array dimension is rows.
For C = 1 To UBound(valarray, 2) ' Second array dimension is columns.
Print #intFNumber, valarray(R, C)
Next C
Next R
'Close the text file
Close #intFNumber
End Sub
For simplicity as I've also not figured out how to obtain the last row with any content in it I've restricted the range to row 40 for now.
Any ideas on how to accomplish what I want elegantly? I've solved it by assigning single cells to variables, but I'd prefer to do it with an array. Ultimately I will later be interjecting a fixed text string after a recurring text string in the imported text, which is then followed by a numerical value obtained from a calculation.
Many thanks for any help and apologies for the ignorance.
In case you have any issues, this versions shows how to determine the last row and column
Option Explicit
Public Sub RangeToFile()
Dim ws As Worksheet, lr As Long, lc As Long, r As Long, c As Long
Dim arr As Variant, fName As String, fNumber As Long, txtLine As String
fName = ThisWorkbook.Path & "\Output.txt" 'File name & path based on workbook path
Set ws = Sheet1 'set a reference to main sheet
lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'find last row in column A
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column 'find last column in row 1
arr = ws.Range(ws.Cells(1, "A"), ws.Cells(lr, lc)) 'Copy range to array
fNumber = FreeFile 'get next available file number assigned by windows
Open fName For Output As #fNumber 'create a new file, or overwrite an existing one
For r = 1 To UBound(arr, 1) '1st array dimension is rows
For c = 1 To UBound(arr, 2) '2nd array dimension is columns
txtLine = txtLine & arr(r, c) & ", " 'concatenate each cell in row, on a line
Next c 'the end of the row, moving to next one
txtLine = Left(txtLine, Len(txtLine) - 2) 'remove the extra comma at end of line
txtLine = txtLine & vbCrLf 'append a carriage return to the line
Next r
txtLine = Left(txtLine, Len(txtLine) - 2) 'remove carriage return at end of line
Print #fNumber, txtLine 'print entire text to the file with an extra carriage return
Close #fNumber 'close the text file
End Sub
and this one transposes columns to rows:
Public Sub RangeToFileColumnsToRows()
Dim ws As Worksheet, lr As Long, lc As Long, r As Long, c As Long
Dim arr As Variant, fName As String, fNumber As Long, txtLine As String
fName = ThisWorkbook.Path & "\Output.txt" 'File name & path based on workbook path
Set ws = Sheet1 'set a reference to main sheet
lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'find last row in column A
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column 'find last column in row 1
arr = ws.Range(ws.Cells(1, "A"), ws.Cells(lr, lc)) 'Copy range to array
fNumber = FreeFile 'get next available file number assigned by windows
Open fName For Output As #fNumber 'create a new file, or overwrite an existing one
For c = 1 To UBound(arr, 2) '2nd array dimension is columns
For r = 1 To UBound(arr, 1) '1st array dimension is rows
txtLine = txtLine & arr(r, c) & ", " 'concatenate each cell in col, on a line
Next r 'the end of the col, moving to next one
txtLine = Left(txtLine, Len(txtLine) - 2) 'remove the extra comma at end of line
txtLine = txtLine & vbCrLf 'append a carriage return to the line
Next c
txtLine = Left(txtLine, Len(txtLine) - 2) 'remove carriage return at end of line
Print #fNumber, txtLine 'print entire text to the file
Close #fNumber 'close the text file
End Sub
Nevermind, I think I got a step forward:
For R = 1 To UBound(valarray, 1) ' First array dimension is rows.
For C = 1 To UBound(valarray, 2) ' Second array dimension is columns.
ReDim Preserve tvalarray(1 To C) 'Reset the array dimension on each iteration of loop whilst keeping results
'Input each single value into subarray for joining
tvalarray(C) = valarray(R, C)
'Join the subarray
jstring = Join(tvalarray)
Next C
ReDim Preserve jvalarray(1 To R) 'Reset the array dimension on each iteration of loop whilst keeping results
'Input the joined result into the new array
jvalarray(R) = jstring
'Print to file
Print #intFNumber, jvalarray(R)
Next R
This seems to do the job, I'll see if I run into pitfalls later.
I have a quick question: I try to sum up in a table of 4 columns column number 2 if the value in column number 1 AND 3 matches. I found a sample code here on stack overflow, but it counts currently based on column 1. I'm new to VBA and don't know what to change or how to adjust the code to base my calculations on column 1 and 3. Here is the sample code:
Option Explicit
Sub testFunction()
Dim rng As Excel.Range
Dim arrProducts() As String
Dim i As Long
Set rng = Sheet1.Range("A2:A9")
arrProducts = getSumOfCountArray(rng)
Sheet2.Range("A1:B1").Value = Array("Product", "Sum of Count")
' go through array and output to Sheet2
For i = 0 To UBound(arrProducts, 2)
Sheet2.Cells(i + 2, "A").Value = arrProducts(0, i)
Sheet2.Cells(i + 2, "B").Value = arrProducts(1, i)
Next
End Sub
' Pass in the range of the products
Function getSumOfCountArray(ByRef rngProduct As Excel.Range) As String()
Dim arrProducts() As String
Dim i As Long, j As Long
Dim index As Long
ReDim arrProducts(1, 0)
For j = 1 To rngProduct.Rows.Count
index = getProductIndex(arrProducts, rngProduct.Cells(j, 1).Value)
If (index = -1) Then
' create value in array
ReDim Preserve arrProducts(1, i)
arrProducts(0, i) = rngProduct.Cells(j, 1).Value ' product name
arrProducts(1, i) = rngProduct.Cells(j, 2).Value ' count value
i = i + 1
Else
' value found, add to id
arrProducts(1, index) = arrProducts(1, index) + rngProduct.Cells(j, 2).Value
End If
Next
getSumOfCountArray = arrProducts
End Function
Function getProductIndex(ByRef arrProducts() As String, ByRef strSearch As String) As Long
' returns the index of the array if found
Dim i As Long
For i = 0 To UBound(arrProducts, 2)
If (arrProducts(0, i) = strSearch) Then
getProductIndex = i
Exit Function
End If
Next
' not found
getProductIndex = -1
End Function
Sum Column B based on Column A using Excel VBA Macro
Could you please advise me how I can solve this problem. Below you can find a sample picture of my small table. The quantity of the yellow part, for instance, shall be summed up and the second row shall be deleted.
Sample Table - Picture
you said "I try to sum up in a table of 4 columns column number 2" but from your "Sample Table - Picture" I'd understand you want to sum up column number 4
edited after OP variation of data range
Assuming what above you could try the following
Option Explicit
Sub main()
On Error GoTo 0
With ActiveSheet '<== set here the actual sheet reference needed
' With .Range("A:D").Resize(.cells(.Rows.Count, 1).End(xlUp).row) '<== here adjust "A:D" to whatever colums range you need
With .Range("A51:D" & .cells(.Rows.Count, "A").End(xlUp).row) '<== here adjust "A:D" to whatever colums range you need
With .Offset(1).Resize(.Rows.Count - 1)
.Offset(, .Columns.Count).Resize(, 1).FormulaR1C1 = "=SUMIFS(C2, C1,RC1,C3, RC3)" '1st "helper column is the 1st column at the right of data columns (since ".Offset(, .Columns.Count)")
.Columns(2).Value = .Offset(, .Columns.Count).Resize(, 1).Value 'reference to 1st "helper" column (since ".Offset(, .Columns.Count)")
.Offset(, .Columns.Count).Resize(, 1).FormulaR1C1 = "=concatenate(RC1,RC3)"
With .Offset(, .Columns.Count + 1).Resize(, 1) '2nd "helper" column is the 2nd column at the right of data columns (since ".Offset(, .Columns.Count + 1)"
.FormulaR1C1 = "=IF(countIF(R1C[-1]:RC[-1],RC[-1])=countif(C[-1],RC[-1]),1,"""")" 'reference to 1st "helper" column (with all those "C[-1]")
.Value = .Value
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Offset(, -1).Resize(, 2).ClearContents ' reference to both "helper" columns: ".Offset(, -1)" reference the 1st since it shifts one column to the left from the one referenced in the preceeding "With.." statement (which is the 2nd column at thre right of data columns) and ".Resize(, 2)" enlarges to encose the adjacent column to the right
End With
End With
End With
End With
End Sub
it makes use of two "helper" columns, which I assumed could be the two adjacent to the last data columns (i.e.: if data columns are "A:D" then helper columns are "E:F")
should you need to use different "helper" columns then see comments about how they are located and change code accordingly
Thanks for reading my question,
I was given a list of about 250k entries along with names and sign in dates to accompany each entry to show when they logged. My task is to find out which users signed in on consecutive days, how often and how many times.
i.e. Bob smith had 3 consecutive days one time, 5 consecutive days 3 times.
joe smith had 8 consecutive days once, 5 consecutive days 8 times
etc
I am brand new to VBA and have been struggling to write a program to do this.
code:
Option Explicit
Option Base 1
Sub CountUUIDLoop()
Dim UUID As String
Dim Day As Date
Dim Instance() As Variant
ReDim Instance(50, 50)
Dim CountUUID As Variant
Dim q As Integer
Dim i As Long
Dim j As Long
Dim f As Integer
Dim g As Integer
Dim LastRow As String
f = 1
q = 1
g = 2
LastRow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
For i = q To LastRow
UUID = Cells(i, "A")
Instance(f, 1) = UUID
g = 2
For j = 1 To LastRow
If UUID = Cells(j, "A") Then
Instance(f, g) = Cells(j, "B")
g = g + 1
End If
Next j
f = f + 1
q = g - 1
Next i
End Sub
The goal of this code is to go through the entries and store them in the array 'Instance' such that the 2D array would look like [UUID1, B1, B2, B3]
[UUID2, B1, B2, B3, B4]
[UUID3, B1, B2]
Where the UUID is the user, the B1 represents the date that user signed in, b2 would be the next date they signed in etc. Some users have more or less dates than others.
My main issue has come with setting up the array as I keep getting different errors around it. I'm not sure how to define this 2D array partly because there will be over 30 000 rows, each with 1->85 columns.
Any help is appreciated, let me know if anything needs further clarification. Once again this is my first time using VBA so im sorry ahead of time if everything i've been doing is wrong.
P.S. I used ReDim Instance (50,50) as a test to see if i could make it work by predefining but same errors occurred. Thanks again!
As far as I understand from your question and code, you have a table with following structure:
..............A.................B
1........LOGIN1.......DATE1
2........LOGIN1.......DATE2
3........LOGIN1.......DATE3
4........LOGIN2.......DATE4
5........LOGIN2.......DATE5
6........LOGIN3.......DATE6
And your task in this code was to fetch data in a 2D structure like this:
RESULT_ARRAY-
............................|-LOGIN1-
............................................|-DATE1
............................................|-DATE2
............................................|-DATE3
............................|-LOGIN2-
............................................|-DATE4
............................................|-DATE5
............................|-LOGIN3-
............................................|-DATE6
First of all, you need to know what goes wrong in your code. Please see comments in code below to find out the reason of error:
Option Explicit
Option Base 1
Sub CountUUIDLoop()
Dim UUID As String
Dim Day As Date
Dim Instance() As Variant ' If you are using variant data type, it is not necesary to point it: default data type in VBA is Variant. Just write like this: "Dim Instance()"
ReDim Instance(50, 50) ' Limitation in 50 may be the reason, why your script is going into "out of range" error.
' Remember, that this operation means, that your array now will have following dimentions: [1..50,1..50]
Dim CountUUID As Variant 'Just write like this: "Dim CountUUID"
Dim q As Integer ' you can describe all your variables in one line, like this: "Dim q as Integer,f as Integer,g as Integer"
Dim i As Long
Dim j As Long
Dim f As Integer
Dim g As Integer
Dim LastRow As String ' first mistake: you are using String data type to perform numeric operations below in your FOR-cycle
f = 1 ' Your Instance array index starts from {0} and you are not using this index by starting from {1}.
q = 1 ' The reason to use this variable is not obvious. You could just use constant in FOR cycle below and avoid unnecessary variables.
g = 2 ' You could remove this line, because this var is set every time in cycle below (before second FOR)
LastRow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row ' The alternative here is to use predefined Excel constants, like this:
' "Cells.SpecialCells(xlLastCell).Row".
'If LastRow is bigger, than {50} - this could be a reason of your Error.
For i = q To LastRow ' Here goes comparison between String and Integer data type, not good thing, but type conversion should work fine here.
UUID = Cells(i, "A") ' No need to perform re-set here, just move forward and assign value from this cell to the Instanse directly:
' Like this: Instance(f, 1) = Cells(i, "A")
Instance(f, 1) = UUID
g = 2
For j = 1 To LastRow ' It is another point, why "q" variable is not necessary. :)
If UUID = Cells(j, "A") Then ' You could use your Instansce value instead of UUID there, like this: "Instance(f, 1)"
Instance(f, g) = Cells(j, "B") 'If "g" variable will somehow become bigger, than {49}, this could become a reason of your Error.
g = g + 1
End If
Next j
f = f + 1
q = g - 1 ' "q" variable is not used after this row, so it is a strange unnecessary action
Next i
End Sub
Now, when we have some information about error, let me do some improvements on your code. I am certain, that to make most simply code, you can use your Excel worksheets to store and count data with VBA as background automations. But if you need the code with arrays, let's do this! :)
Option Explicit ' It is an option that turns on check for every used variable to be defined before execution. If this option is not defined, your code below will find undefined variables and define them when they are used. Good practice is to use this option, because it helps you, for example to prevent missprinting errors in variable names.
Option Base 1 ' This option sets the default index value for arrays in your code. If this option is not set, the default index value will be {0}.
Const HEADER_ROW = 1 ' It is a number to identify your header row, next row after this one will be counted as a row with data
Const UUID = 1 ' ID of element in our "Instance" array to store UUID
Const DATES_ID = 2 ' ID of element in our "Instance" array to store dates
Function CountUUIDLoop()
ActiveSheet.Copy After:=ActiveSheet 'Copy your worksheet to new one to ensure that source data will not be affected.
Dim Instance(), dates() ' "Instance" will be used to store all the data, "dates" will be used to store and operate with dates
ReDim Instance(2, 1) ' Set first limitation to the "Instance" array in style [[uuid, dates],id]
ReDim dates(1) ' Set first limitation to the "dates" array
Instance(DATES_ID, 1) = dates
Dim CountUUID
Dim i as Long, j as Long, f as Long, active_element_id As Long 'Integer is quite enough to perform our array manipulations, but Long datatype is recomended (please refer to UPDATE2 below)
i = HEADER_ROW + 1 ' Set first row to fetch data from the table
active_element_id = 1 ' Set first active element number
With ActiveSheet ' Ensure that we are working on active worksheet.
While .Cells(i, 1) <> "" 'If operated cell is not empty - continue search for data
If i > HEADER_ROW + 1 Then
active_element_id = active_element_id + 1 ' increment active element number
ReDim Preserve Instance(2, active_element_id) ' Assign new limitation (+ 1) for our Instances, don't forget to preserve our results.
ReDim dates(1) ' Set first limitation to the "dates" array
Instance(DATES_ID, active_element_id) = dates
End If
Instance(UUID, active_element_id) = .Cells(i, 1) ' save UUID
dates(1) = .Cells(i, 2) ' save first date
j = i + 1 ' Set row to search next date from as next row from current one.
While .Cells(j, 1) <> "" 'If operated cell is not empty - continue search for data
If .Cells(j, 1) = .Cells(i, 1) Then
ReDim Preserve dates(UBound(dates) + 1) ' Expand "dates" array, if new date is found.
dates(UBound(dates)) = .Cells(j, 2) ' Save new date value.
.Cells(j, 1).EntireRow.Delete 'Remove row with found date to exclude double checking in future
Else
j = j + 1 ' If uuid is not found, try next row
End If
Wend
Instance(DATES_ID, active_element_id) = dates
i = i + 1 'After all the dates are found, go to the next uuid
Wend
.Cells(i, 1) = "UUID COUNT" ' This will write you a "UUID COUNT" text in A column below all the rest of UUIDs on active worksheet
.Cells(i, 2) = i - HEADER_ROW - 1 ' This will write you a count of UUIDs in B column below all the rest of UUIDs on active worksheet
End With
CountUUIDLoop = Instance ' This ensures that your function (!) returns an array with all UUIDs and dates inside.
End Function
This function will print you count of your UUIDs at the bottom of active sheet and return you an array like this:
[[LOGIN1][1], [[DATE1][DATE2][DATE3]][1]]
I have used this order of storing data to avoid error with expanding of multidimentional arrays. This error is similar to yours, so you could read more about this there: How can I "ReDim Preserve" a 2D Array in Excel 2007 VBA so that I can add rows, not columns, to the array? Excel VBA - How to Redim a 2D array? ReDim Preserve to a Multi-Dimensional Array in Visual Basic 6
Anyway, you could use my function output ("Instance" array) to perform your further actions to find what you need or even display your uuid-dates values. :)
Good luck in your further VBA actions!
UPDATE
Here is the test procedure showing how to work with the above function's results:
Sub test()
Dim UUIDs ' The result of the "CountUUIDLoop" function will be stored there
Dim i as Long, j As Long ' Simple numeric variables used as indexies to run through our resulting array
UUIDs = CountUUIDLoop ' assign function result to a new variable
Application.DisplayAlerts = False ' Disable alerts from Excel
ActiveSheet.Delete ' Delete TMP worksheet
Application.DisplayAlerts = True ' Enable alerts from Excel
If UUIDs(UUID, 1) <> Empty Then ' This ensures that UUIDs array is not empty
Sheets.Add After:=ActiveSheet ' Add new worksheet after active one to put data into it
With ActiveSheet 'Ensure that we are working with active worksheet
.Cells(HEADER_ROW, 1) = "UUIDs/dates" ' Put the header into the "HEADER_ROW" row
For i = 1 To UBound(UUIDs, 2) ' run through all the UUIDs
.Cells(1 + HEADER_ROW, i) = UUIDs(UUID, i) ' Put UUID under the header
For j = 1 To UBound(UUIDs(DATES_ID, i)) ' run through all the dates per UUID
.Cells(j + 1 + HEADER_ROW, i) = UUIDs(DATES_ID, i)(j) ' put date into column below the UUID
Next j ' Go to next date
Next i ' Go to next UUID
.Cells.EntireColumn.AutoFit ' This will make all columns' width to fit its contents
End With
Else
MsgBox "No UUIDs are found!", vbCritical, "No UUIDs on worksheet" ' Show message box if there are no UUIDs in function result
End If
End Sub
So, if you'll have following data on the active worksheet:
..............A.................B
1........LOGIN1.......DATE1
2........LOGIN1.......DATE2
3........LOGIN1.......DATE3
4........LOGIN2.......DATE4
5........LOGIN2.......DATE5
6........LOGIN3.......DATE6
...this sub will put UUIDs on the new sheet like this:
..............A.................B.................C
1........UUIDs/dates
2........LOGIN1........LOGIN2........LOGIN3
3........DATE1.........DATE4.........DATE6
4........DATE2.........DATE5
5........DATE3
UPDATE2
It is recomended to use Long data type instead of Integer each type when integer (or whole number) variable is needed. Long is slightly faster, it has much wider limitations and costs no additional memory. Here is proof link:
MSDN:The Integer, Long, and Byte Data Types
I would recommend using collections and a dictionary instead of arrays. The below code will structure the data in a way that is very similar to the way you wanted it.
Sub collect_logins_by_user_()
'you need to enable the microsoft scripting runtime
'in tools - references
'assuming unique ids are in col A and there are no gaps
'and assuming dates in col B and there are no gaps
'
'The expected runtime for this is O(n) and I have used similar code on more than 250.000 record.
'It still takes a while obviously, but should run just fine.
'
'The the data will bestructed in the following format:
'{id_1: [d_1, d_2,...], id_2: [d_3, d_4,...], ...}
Dim current_id As Range: Set current_id = ActiveSheet.Range("A2") 'modify range as required
Dim logins_by_users As New Dictionary
While Not IsEmpty(current_id)
If Not logins_by_users.Exists(current_id.Value) Then
Set logins_by_users(current_id.Value) = New Collection
End If
logins_by_users(current_id.Value).Add current_id.Offset(ColumnOffset:=1).Value
Set current_id = current_id.Offset(RowOffset:=1)
Wend
'Once you have the data structured, you can do whatever you want with it.
'like printing it to the immediate window.
Dim id_ As Variant
For Each id_ In logins_by_users
Debug.Print "======================================================="
Debug.Print id_
Dim d As Variant
For Each d In logins_by_users(id_)
Debug.Print d
Next d
Next id_
Debug.Print "======================================================="
End Sub
I have written a bit of code that does something along the lines of what you are trying to do - it prints to the debug window the different numbers of consecutive logs per user, separeted by commas.
This code makes use of the dictionary object - which essentially is an associative array where the indexes are not restrained to numbers like they are in arrays, and offers a couple of convenient features to manipulate data that arrays don't.
I have tested this on a sheet including user ids in colomn A and log dates in column B - including headers - and this looks to work fine. Fell free to give it a try
Sub mysub()
Dim dic As Object
Dim logs As Variant
Dim myval As Long
Dim mykey As Variant
Dim nb As Long
Dim i As Long
Set dic = CreateObject("Scripting.dictionary")
'CHANGE TO YOUR SHEET REFERENCE HERE
For Each cell In Range(Cells(2, 1), Cells(Worksheets("Sheet8").Rows.count, 1).End(xlUp))
mykey = cell.Value
myval = cell.Offset(0, 1)
If myval <> 0 Then
On Error GoTo ERREUR
dic.Add mykey, myval
On Error GoTo 0
End If
Next cell
For Each Key In dic
logs = Split(dic(Key), ",")
logs = sortArray(logs)
i = LBound(logs) + 1
nb = 1
Do While i <= UBound(logs)
Do While CLng(logs(i)) = CLng(logs(i - 1)) + 1
nb = nb + 1
i = i + 1
Loop
If nb > 1 Then
tot = tot & "," & CStr(nb)
nb = 1
End If
i = i + 1
Loop
If tot <> "" Then dic(Key) = Right(tot, Len(tot) - 1)
Debug.Print "User: " & Key & " - Consecutive logs: " & dic(Key)
tot = ""
mys = ""
Next Key
Exit Sub
ERREUR:
If myval <> 0 Then dic(mykey) = dic(mykey) & "," & CStr(myval)
Resume Next
End Sub
Function sortArray(a As Variant) As Variant
For i = LBound(a) + 1 To UBound(a)
j = i
Do While a(j) < a(j - 1)
temp = a(j - 1)
a(j - 1) = a(j)
a(j) = temp
j = j - 1
If j = 0 Then Exit Do
Loop
Next i
sortArray = a
End Function