Loop through column, store values in an array - excel

I am trying to find a way to:
Loop through a column (B column)
Take the values, store them in an array
Loop through that array and do some text manipulation
However, I cannot think of a way to loop through a column and take those values, storing them in an array. I have looked through Stack Overflow and google but have not found a successful solution.
In advance, thank you for your help.
Sub collectNums()
Dim eNumStorage() As String ' initial storage array to take values
Dim i as Integer
Dim j as Integer
Dim lrow As Integer
lrow = Cells(Rows.Count, "B").End(xlUp).Row ' The amount of stuff in the column
For i = lrow To 2 Step -1
If (Not IsEmpty(Cells(i, 2).Value)) Then ' checks to make sure the value isn't empty
i = eNumStorage ' I know this isn't right
Next i
If (IsEmpty(eNumStorage)) Then
MsgBox ("You did not enter an employee number for which to query our database. Quitting")
Exit Sub
End If
End Sub

This is the easiest way to get column to array:
Public Sub TestMe()
Dim myArray As Variant
Dim cnt As Long
myArray = Application.Transpose(Range("B1:B10"))
For cnt = LBound(myArray) To UBound(myArray)
myArray(cnt) = myArray(cnt) & "something"
Next cnt
For cnt = LBound(myArray) To UBound(myArray)
Debug.Print myArray(cnt)
Next cnt
End Sub
It takes the values from B1 to B10 in array and it gives possibility to add "something" to this array.
The Transpose() function takes the single column range and stores it as an array with one dimension. If the array was on a single row, then you would have needed a double transpose, to make it a single dimension array:
With Application
myArray = .Transpose(.Transpose(Range("A1:K1")))
End With
MSDN Transpose
CPearson Range To Array
Creating an Array from a Range in VBA

Just adding a variation on Vityata's which is the simplest way. This method will only add non-blank values to your array. When using your method you must declare the size of the array using Redim.
Sub collectNums()
Dim eNumStorage() As String ' initial storage array to take values
Dim i As Long
Dim j As Long
Dim lrow As Long
lrow = Cells(Rows.Count, "B").End(xlUp).Row ' The amount of stuff in the column
ReDim eNumStorage(1 To lrow - 1)
For i = lrow To 2 Step -1
If (Not IsEmpty(Cells(i, 2).Value)) Then ' checks to make sure the value isn't empty
j = j + 1
eNumStorage(j) = Cells(i, 2).Value
End If
Next i
ReDim Preserve eNumStorage(1 To j)
'Not sure what this bit is doing so have left as is
If (IsEmpty(eNumStorage)) Then
MsgBox ("You did not enter an employee number for which to query our database. Quitting")
Exit Sub
End If
For j = LBound(eNumStorage) To UBound(eNumStorage) ' loop through the previous array
eNumStorage(j) = Replace(eNumStorage(j), " ", "")
eNumStorage(j) = Replace(eNumStorage(j), ",", "")
Next j
End Sub

Related

Is there a way to AND across a row of a 2D Array?

Using VBA, I would like to AND across each row in a 2D array and star the result in separate 1D array without ANDing a single pair the ANDing the result with the next item in that row.
FYI This is my first time using 2D arrays so sorry if there is an obvious solution.
For example if the data in my sheet looked like this (the actual range is much larger):
I would like to do the equlavant of an excel formula: =AND(B2:D2) then =AND(B3:D3), etc...
I have code that sets everything up but I don't know how to proceed except to loop across each element of a row, store the result then loop across the next, etc, etc. I'm hoping the there is a much better (more efficient) way to proceed.
Here is my code so far
Sub Exceptions()
' Setup worksheet
Dim wks As Worksheet
Set wks = cnTest
' Find last row of range
Dim LastRow As Long
LastRow = Find_LastRow(wks) 'Functionthat returns last row
' load range into array
Dim MyArray As Variant
MyArray = wks.Range("B2:D8")
' Setup 1D Result array
Dim Results As Variant
Results = wks.Range("A2:A8")
Dim i As Long
For i = 1 To LastRow
' Perform AND function on each row of the array
' then place result in 1D array (Results())
' If this were a formul: =AND(B2:D2)
'
' Is there way to "AND" across a row in and array or
' must I "AND" MyArray(1,1) with MyArray(1,2) then AND
' that result with MyArray(1,3)
Next i
End Sub
Thank you
Try this.
Sub Exceptions()
' Setup worksheet
' load range into array
Dim MyArray As Variant
MyArray = ActiveSheet.Range("B2:D8")
' Setup 1D Result array
Dim Results As Variant
Results = ActiveSheet.Range("A2:A8")
Dim i As Long
Dim X As Long
For i = 1 To UBound(MyArray, 1)
Results(i, 1) = "True"
For X = 1 To UBound(MyArray, 2)
If MyArray(i, X) = False Then
Results(i, 1) = "False"
Exit For
End If
Next X
Next i
End Sub
Try,
Sub test()
Dim vR()
Dim rngDB As Range, rng As Range
Dim i As Long, r As Long
Set rngDB = Range("b2:b8")
r = rngDB.Rows.Count
ReDim vR(1 To r)
For Each rng In rngDB
i = i + 1
vR(i) = WorksheetFunction.And(rng.Resize(1, 3))
Next rng
Range("a2").Resize(r) = WorksheetFunction.Transpose(vR)
End Sub
In the formula bar, type:
=IF(-PRODUCT(IF(A1,-1,0),IF(C1,-1,0)),TRUE,FALSE)
(if the data is in columns A and C), and drag down.
Because, as everyone knows, A AND B = AB if A and B are Boolean variables (and watch the minus in front of the PRODUCT).

Concat a string to a range of cells in vba?

From cells E1:E25, I want to concat the word "hi" at the end of each word that exists in that range within my vba code. Here is what I have so far:
Workbooks("Test.xlsx").Worksheets("Sheet1").Range("E1:E25").Value = Workbooks("Test.xlsx").Worksheets("Sheet1").Range("E1:E25").Value + "hi"
It is giving me a "mismatch" error. Is there something I'm doing wrong?
I know there is a function to do this, I just want to know the VBA way.
Add Suffix
Copy both procedures to a standard module.
Adjust the values in the first procedure.
Only run the first procedure, the second is being called (by the
first).
The Code
Option Explicit
Sub addHi()
Dim rng As Range
Set rng = Workbooks("Test.xlsx").Worksheets("Sheet1").Range("E1:E25")
addSuffix rng, "Hi"
End Sub
Sub addSuffix(ByRef DataRange As Range, ByVal Suffix As String)
Dim Data As Variant, i As Long, j As Long
' Write values from range to array.
Data = DataRange.Value
' Loop through rows of array.
For i = 1 To UBound(Data)
' Loop through columns of array.
For j = 1 To UBound(Data, 2)
' Check if current value in array is not an error.
If Not IsError(Data(i, j)) Then
' Add suffix.
Data(i, j) = Data(i, j) & Suffix
' Write new current value to the Immediate window (CTRL+G).
'Debug.Print Data(i, j)
End If
Next j
Next i
' Write values from array to range.
DataRange.Value = Data
End Sub
#Tim Williams is correct. Loop over the cells in the range and update the values.
For Each Cell In Workbooks("Test.xlsx").Worksheets("Sheet1").Range("E1:E25")
Cell.Value = Cell.Value + "hi"
Next

I need this matching method to skip over blank cells and not include them as a matched value

This code works almost perfectly. The problem is it includes blank cells in its "matched" results. What do I need to change to make this code ignore blank cells? Below I will include an example of what is going on.
Sub MarkMatches()
Const TopLeftCell As String = "A2" ' change to match where your data are
Dim Rng As Range ' data range
Dim FirstRow As Long, FirstClm As Long
Dim Data As Variant ' original data (2-D)
Dim Arr As Variant ' data rearranged (1-D)
Dim Tmp As Variant ' working variable
Dim R As Long, R1 As Long ' row counters
Dim C As Long ' column counter
Dim Count() As String ' match counter
With Range(TopLeftCell)
FirstRow = .Row
FirstClm = .Column
End With
C = Cells(FirstRow, Columns.Count).End(xlToLeft).Column
Set Rng = Range(Cells(FirstRow, FirstClm), _
Cells(Rows.Count, FirstClm).End(xlUp).Offset(0, C - FirstClm))
Data = Rng.Value
ReDim Arr(1 To UBound(Data))
For R = 1 To UBound(Data)
ReDim Tmp(1 To UBound(Data, 2))
For C = 1 To UBound(Data, 2)
Tmp(C) = Data(R, C)
Next C
Arr(R) = Tmp
Next R
ReDim Count(1 To UBound(Arr))
For R = 1 To UBound(Arr) - 1
For R1 = R + 1 To UBound(Arr)
Tmp = 0
For C = 1 To UBound(Arr(R))
If Not IsError(Application.Match(Arr(R)(C), Arr(R1), 0)) Then
Tmp = Tmp + 1
End If
Next C
If Tmp > 0 Then ' change to suit
Tmp = Format(Tmp, "(0)") & ", "
Count(R) = Count(R) & CStr(R1 + FirstRow - 1) & Tmp
Count(R1) = Count(R1) & CStr(R + FirstRow - 1) & Tmp
End If
Next R1
Next R
For R = 1 To UBound(Count)
If Len(Count(R)) Then Count(R) = Left(Count(R), Len(Count(R)) - 2)
Next R
' set the output column here (2 columns right of the last data column)
' to avoid including this column in the evaluation
' it must be blank before a re-run
Set Rng = Rng.Resize(, 1).Offset(0, UBound(Data, 2) + 1)
Rng.Value = Application.Transpose(Count)
End Sub
Thank you #Variatus for the code and help so far!
I tried to work with your original code, but honestly I became very confused. My example below will illustrate some practices that could help (and those who may review your code later, including yourself!). So here's a list of comments:
Always use Option Explicit. Your code may already have this, but I'm listing it here for completeness sake.
Create variable names that describe what data it holds. Your code does a little of this, but some of the variable names are difficult to fit into the logic flow. My idea in coding is always to try and write self-documenting code. That way, it's nearly always clear what the code is trying to accomplish. Then I'll use comment for code blocks where it might be a bit less clear. (Don't fall into the trap of prefixing variable names with a "type" or something; it's ultimately not worth it.)
A clear description of the problem always helps. This is true not only to get help on SO, but also for yourself. My final comment to your post above, asking about the problem description really simplified everything. This includes describing what you want your output to show.
As per the problem description, you need to identify each unique item and keep track of which row you find that item so you can create a report later. A Dictionary is a perfect tool for this. Read up about how to use a Dictionary, but you should be able to follow what this block of code is doing here (even without all the previous declarations):
For Each cell In dataArea.Cells
If Not IsEmpty(cell) Then
If items.Exists(cell.Value) Then
'--- add this row to the list
rowList = items(cell.Value) & "," & cell.Row
items(cell.Value) = rowList
Else
'--- first time adding this value
items.Add cell.Value, cell.Row
End If
End If
Next cell
It's easy to see how the logic of this code follows the description of the problem. After that, it's just a matter of running through each row in the data area and checking each value on that row to see if duplicates exist on any other row. The full example solution is below for you to study and adjust to fit your situation.
Option Explicit
Sub IdentifyMatches()
Dim ws As Worksheet
Set ws = Sheet1
Dim dataArea As Range
Set dataArea = ws.Range("A1:F6")
Dim items As Dictionary
Set items = New Dictionary
'--- build the data set of all unique items, and make a note
' of which row the item appears.
' KEY = cell value
' VALUE = CSV list of row numbers
Dim rowList As String
Dim cell As Range
For Each cell In dataArea.Cells
If Not IsEmpty(cell) Then
If items.Exists(cell.Value) Then
'--- add this row to the list
rowList = items(cell.Value) & "," & cell.Row
items(cell.Value) = rowList
Else
'--- first time adding this value
items.Add cell.Value, cell.Row
End If
End If
Next cell
'--- now work through the data, row by row and make the report
Dim report As String
Dim duplicateCount As Variant
ReDim duplicateCount(1 To dataArea.Rows.Count)
Dim dataRow As Range
For Each dataRow In dataArea.Rows
Erase duplicateCount
ReDim duplicateCount(1 To dataArea.Rows.Count)
Dim rowNumber As Variant
For Each cell In dataRow.Cells
If items.Exists(cell.Value) Then
rowList = items(cell.Value)
Dim rowNumbers As Variant
rowNumbers = Split(rowList, ",")
For Each rowNumber In rowNumbers
If rowNumber <> cell.Row Then
duplicateCount(rowNumber) = duplicateCount(rowNumber) + 1
End If
Next rowNumber
End If
Next cell
report = vbNullString
For rowNumber = 1 To UBound(duplicateCount)
If duplicateCount(rowNumber) > 0 Then
report = report & rowNumber & "(" & duplicateCount(rowNumber) & ")" & ", "
End If
Next rowNumber
'--- display the report in the next column at the end of the data area
If Len(report) > 0 Then
report = Left$(report, Len(report) - 2) 'removes the trailing comma and space
dataRow.Cells(1, dataRow.Columns.Count + 1).Value = report
End If
Next dataRow
End Sub

how can I insert a condition "if it contains" to search for a specific letter in VBA?

I want to count how many times appear the parameters CA, CU and CH, in an excel that looks like this:
I have tried to use the following code, but as the cells don't contain only the parameter I am searching for, it doesn't work:
Sub ContarOV()
Dim cont As Variant
Dim sumaCA As Variant
Dim sumaCU As Variant
Dim sumaCH As Variant
sumaCA = 0
sumaCU = 0
sumaCH = 0
For cont = 3 To 12
If Cells(cont, 2) = ("CA") Then
sumaCA = sumaCA + 1
End If
If Cells(cont, 2) = ("CU") Then
sumaCU = sumaCU + 1
End If
If Cells(cont, 2) = ("CH") Then
sumaCH = sumaCH + 1
End If
Next cont
End Sub
As per #BigBen, I would try to avoid any iteration. What about one of the following options (assuming your data sits from A2:A?):
Sub Test()
Dim lr As Long, x As Long
Dim arr As Variant
Dim rng As Range
With Sheet1 'Change according to your sheets CodeName
'Get last used row
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
'Get data into memory for method 1
arr = Application.Transpose(.Range("A2:A" & lr).Value)
'Create range object for method 2
Set rng = .Range("A2:A" & lr)
'Method 1: Count values with FILTER
Debug.Print UBound(Filter(arr, "CA")) + 1
Debug.Print UBound(Filter(arr, "CU")) + 1
Debug.Print UBound(Filter(arr, "CH")) + 1
'Method 2: Count values with COUNTIF
Debug.Print WorksheetFunction.CountIf(rng, "CA*")
Debug.Print WorksheetFunction.CountIf(rng, "CU*")
Debug.Print WorksheetFunction.CountIf(rng, "CH*")
End With
End Sub
Btw, I would give sumaCA and your other variables a meaningfull data type, Long in this case.
You can use InStr() to return the position of the desired characters in the string. This would look something like If Not InStr(1, Cells(cont,2).Text, "CH") = 0 Then, but looping through strings is generally a slow process. Unless you have a specific need for looping, I like BigBen's answer a lot better than I like looping with InStr().

Compare the Sheet1 column A values with Sheet2 column B, if match then Sheet2.Col C=Sheet1.Col A and Sheet2.Col D=True

I want to compare the Sheet1 column A values with Sheet2 column B, if match then i want to put the Sheet1 Column A values in Sheet2 Column C.
and column D should be populated with 'True'
So i have written the below code:
Sub val()
Dim sheet1_last_rec_cnt As Long
Dim sheet2_last_rec_cnt As Long
Dim sheet1_col1_val As String
Dim cnt1 As Long
Dim cnt2 As Long
sheet1_last_rec_cnt = Sheet1.UsedRange.Rows.Count
sheet2_last_rec_cnt = Sheet2.UsedRange.Rows.Count
For cnt1 = 2 To sheet1_last_rec_cnt
sheet1_col1_val = Sheet1.Range("A" & cnt1).Value
For cnt2 = 2 To sheet2_last_rec_cnt
If sheet1_col1_val = Sheet2.Range("B" & cnt2).Value Then
Sheet2.Range("C" & cnt2).Value = sheet1_col1_val
Sheet2.Range("D" & cnt2).Value = "True"
Exit For
End If
Next
Next
End Sub
Problem is i have one millions of records in both the sheets.
if i use the above code then For loop is running (One million * One million) times. So excel is hanging like anything.
Can someone please help me to optimize the code?
For 1 million records I'm not sure Excel is the best place to be storing this data. If your code is designed to tidy up the data so that you can export it to a database then great ... if not, then, well, I fear rough seas lay ahead for you.
The code below will speed things up a touch as it only loops through each column once, and it populates a collection of unique values so that it only has to check against that instead of the whole column each time. If you sorted your rows then it could be made even quicker but I'll leave that one for you.
Public Sub RunMe()
Dim uniques As Collection
Dim sourceValues As Variant
Dim targetValues As Variant
Dim sourceItem As String
Dim targetItem As String
Dim sourceCount As Long
Dim targetCount As Long
Dim matches As Boolean
Dim output() As Variant
' Acquire the values to be compared.
With ThisWorkbook.Worksheets("Sheet1")
sourceValues = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Value2
End With
With ThisWorkbook.Worksheets("Sheet2")
targetValues = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value2
End With
'Resize the output array to size of target values array.
ReDim output(1 To UBound(targetValues, 1), 1 To 2)
sourceCount = 1
Set uniques = New Collection
'Iterate through the target values to find a match in the source values
For targetCount = 1 To UBound(targetValues, 1)
targetItem = CStr(targetValues(targetCount, 1))
matches = Contains(uniques, targetItem)
If Not matches Then
'Continue down the source sheet to check the values.
Do While sourceCount <= UBound(sourceValues, 1)
sourceItem = CStr(sourceValues(sourceCount, 1))
sourceCount = sourceCount + 1
'Add any new values to the collection.
If Not Contains(uniques, sourceItem) Then uniques.Add True, sourceItem
'Check for a match and leave the loop if we found one.
If sourceItem = targetItem Then
matches = True
Exit Do
End If
Loop
End If
'Update the output array if there's a match.
If matches Then
output(targetCount, 1) = targetItem
output(targetCount, 2) = True
End If
Next
'Write output array to the target sheet.
ThisWorkbook.Worksheets("Sheet2").Range("C2").Resize(UBound(targetValues, 1), 2).value = output
End Sub
Private Function Contains(col As Collection, key As String) As Boolean
'Function to test if the key already exists.
Contains = False
On Error Resume Next
Contains = col(key)
On Error GoTo 0
End Function

Resources