I'm trying to learn how to use a dictionary in Excel VBA. The test is to get all values from rows 1-100000 in column A to a dictionary via an array and then write all the values to column B. This works fine until row 34464, the rest of the rows in column B just gets #N/A.
Any ideas why?
Sub nnn()
'Tools - References - Microsoft Scripting Runtime
Dim myArray As Variant
Dim myRow As Long
Dim dicMyDictionary As Scripting.Dictionary
Set dicMyDictionary = New Scripting.Dictionary
With ThisWorkbook.Worksheets("Sheet1")
myArray = Range(Cells(1, 1), Cells(100000, 1)).Value
For myRow = LBound(myArray, 1) To UBound(myArray, 1)
dicMyDictionary.Add myRow, myArray(myRow, 1)
Next myRow
myArray = dicMyDictionary.Items
.Range("B1").Resize(dicMyDictionary.Count, 1).Value = Application.Transpose(myArray)
Set dicMyDictionary = Nothing
End With
End Sub
Because of the limitations of the worksheetfunction Transpose (see also the links posted by Paul Bica), you need to assign the elements to the array directly. The following should work:
Option Explicit
Sub nnn()
'Tools - References - Microsoft Scripting Runtime
Dim myArray As Variant
Dim myRow As Long
Dim dicMyDictionary As Scripting.Dictionary
Set dicMyDictionary = New Scripting.Dictionary
With ThisWorkbook.Worksheets("Sheet1")
myArray = Range(Cells(1, 1), Cells(100000, 1)).Value
For myRow = LBound(myArray, 1) To UBound(myArray, 1)
dicMyDictionary.Add myRow, myArray(myRow, 1)
Next myRow
ReDim myArray(1 To dicMyDictionary.Count, 1 To 1)
For myRow = 1 To UBound(myArray, 1)
myArray(myRow, 1) = dicMyDictionary(myRow)
Next myRow
.Range("B1").Resize(dicMyDictionary.Count, 1).Value = myArray
Set dicMyDictionary = Nothing
End With
End Sub
Related
I want to create a variant array when using a union to join ranges.
If I select one of the ranges the variant array will work.
When I union, I only receive the row dimensions and not the column dimensions.
For example,
Sub arrTest()
'Declare varbs
Dim ws As Worksheet
Dim myArr() As Variant
Dim lRow As Integer
Dim myRng As Range
'Assign varbs
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
lRow = .Cells(Rows.count, "C").End(xlUp).row
Set myRng = Application.Union(.Range("G3:G" & lRow), .Range("J3:O" & lRow), .Range("AD3:AE" & lRow), .Range("AI3:AI" & lRow))
myArr = myRng.Value2
End With
Will return a variant of
myArr(1, 1)
myArr(2, 1)
myArr(1, 3)
However if I were to select one of the ranges within the union for example:
Sub arrTest()
'Declare varbs
Dim ws As Worksheet
Dim myArr() As Variant
Dim lRow As Integer
Dim myRng As Range
'Assign varbs
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
lRow = .Cells(Rows.count, "C").End(xlUp).row
Set myRng = .Range("J3:O" & lRow)
myArr = myRng.Value2
End With
I properly get
myArr(1, 1)
myArr(1, 2)
myArr(1, 3)
etc.
How do I return the column dimensions as well, without looping through the sheet?
Like this:
Sub ArrayTest()
Dim ws As Worksheet
Dim arr, lrow As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
lrow = ws.Cells(Rows.Count, "C").End(xlUp).Row
arr = GetArray(ws.Range("G3:G" & lrow), ws.Range("J3:O" & lrow), _
ws.Range("AD3:AE" & lrow), ws.Range("AI3:AI" & lrow))
With ThisWorkbook.Worksheets("Sheet2").Range("B2")
.Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End With
End Sub
'Given a number of input ranges each consisting of one or more columns (assumed all input ranges have
' the same # of rows), return a single 1-based 2D array with the data from each range
Function GetArray(ParamArray sourceCols() As Variant) As Variant
Dim arr, rng, numCols As Long, numRows As Long, r As Long, c As Long, tmp, col As Long
numRows = sourceCols(0).Rows.Count
'loop over ranges and get the total number of columns
For Each rng In sourceCols
numCols = numCols + rng.Columns.Count
Next rng
ReDim arr(1 To numRows, 1 To numCols) 'size the output array
c = 0
For Each rng In sourceCols 'loop the input ranges
tmp = As2DArray(rng) 'get range source data as array ####
For col = 1 To UBound(tmp, 2) 'each column in `rng`
c = c + 1 'increment column position in `arr`
For r = 1 To numRows 'fill the output column
arr(r, c) = tmp(r, col)
Next r
Next col
Next rng
GetArray = arr
End Function
'Get a range's value, always as a 2D array, even if only a single cell
Function As2DArray(rng)
If rng.Cells.Count > 1 Then
As2DArray = rng.Value
Else
Dim arr(1 To 1, 1 To 1)
arr(1, 1) = rng.Value
As2DArray = arr
End If
End Function
I'm new to VBA.
I have this formula in Excel in a new column (U) for each row, but takes too long and crashes:
=IF(COUNTIFS($E:$E,E2,$A:$A,"<>"&A2)>0,"Yes","No")
Is there a way to make this in VBA?
Thanks
Based on my understanding of your Excel formula. You are trying to put "Yes" in column U for each row where its value in column E is found elsewhere in Column E, but only if the Column A value is different.
Here is how you would do that in VBA:
Sub Example()
Dim Sh As Worksheet
Set Sh = ActiveSheet
Dim LastRow As Integer
LastRow = Sh.Cells(Sh.Rows.Count, "E").End(xlUp).Row
Dim TargetRange As Range
Set TargetRange = Sh.Range("A2:E" & LastRow)
Dim vArr() As Variant
vArr = TargetRange.Value
Dim ColU() As Variant
ReDim ColU(1 To UBound(vArr, 1), 1 To 1)
Dim i As Long
For i = 1 To UBound(vArr, 1)
ColU(i, 1) = "No"
Dim j As Long
For j = 1 To UBound(vArr, 1)
If vArr(i, 5) = vArr(j, 5) And vArr(i, 1) <> vArr(j, 1) Then
ColU(i, 1) = "Yes"
Exit For
End If
Next
Next
Sh.Range("U2").Resize(UBound(vArr, 1)).Value = ColU
End Sub
I first take the values of range A:E into an array. Then I loop through the array checking if my statement is true. If true, "Yes", otherwise default to "No". And then I output the answers to column U.
The downside to this approach is that it is n^2 number of iterations, as I loop through the array for each row of the array. It will be inevitably slow with a very large dataset.
An improvement suggested by #ChrisNeilsen was to start the inner loop from i, cutting the iterations by half. To encorporate this idea, I set up the ColU default values in its own loop first, and then when finding duplicates, I can set both of the duplicates to "Yes" at the same time.
Sub Example()
Dim Sh As Worksheet
Set Sh = ActiveSheet
Dim LastRow As Integer
LastRow = Sh.Cells(Sh.Rows.Count, "E").End(xlUp).Row
Dim TargetRange As Range
Set TargetRange = Sh.Range("A2:E" & LastRow)
Dim vArr() As Variant
vArr = TargetRange.Value
Dim ColU() As Variant
ReDim ColU(1 To UBound(vArr, 1), 1 To 1)
Dim i As Long
For i = 1 To UBound(vArr, 1)
ColU(i, 1) = "No"
Next
For i = 1 To UBound(vArr, 1)
Dim j As Long
For j = i To UBound(vArr, 1)
If vArr(i, 5) = vArr(j, 5) And vArr(i, 1) <> vArr(j, 1) Then
ColU(i, 1) = "Yes"
ColU(j, 1) = "Yes"
Exit For
End If
Next
Next
Sh.Range("U2").Resize(UBound(vArr, 1)).Value = ColU
End Sub
Rather than a double loop (which runs in order n^2) another approach that uses a single loop would be to use a lookup instead of the inner loop (this runs in order n, although a little more complex on each iteration).
Something like
Sub Example2()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, 5).End(xlUp).Row
Dim TargetRange As Range
Set TargetRange = ws.Range(ws.Cells(2, 1), ws.Cells(LastRow, 5))
Dim vArr() As Variant
vArr = TargetRange.Value2
Dim ColU() As Variant
ReDim ColU(1 To UBound(vArr, 1), 1 To 1)
Dim i As Long
Dim j As Long
Dim rE As Range
Set rE = ws.Range(ws.Cells(2, 5), ws.Cells(LastRow, 5))
ColU(UBound(vArr, 1), 1) = "No"
For i = 1 To UBound(vArr, 1) - 1
j = 0
On Error Resume Next
j = Application.WorksheetFunction.XMatch(vArr(i, 5), rE.Offset(i, 0), 0, 1)
On Error GoTo 0
ColU(i, 1) = "No"
If j > 0 Then
If vArr(i, 1) <> vArr(j + i, 1) Then
ColU(i, 1) = "Yes"
ColU(j + i, 1) = "Yes"
End If
End If
Next
ws.Range("U2").Resize(UBound(vArr, 1)).Value = ColU
End Sub
On my hardware, a arbitary sample data set ran
Rows
double loop
this code
100
0.015
0.01
1000
0.17
0.03
10000
11.9
0.33
50000
285.0
2.0
I have been trying to match Date with week number i.e. ("B1:F1")
then date with Year-month i.e. ("A2:A500")
If matches then copy the value from this table that i have highlighted according to the date which is available in code where week is 2 and month is May-2021. Can someone please help me to achieve this.
There are multiple dates which i need to iterate with this table to get different values according to weeks and Year-Months.
Your help will be much appreciated.
Sub findMatchingRecords()
Dim rng1 As Range
Dim rng2 As Range
Dim ws As Worksheet
Dim getdate As String
Dim GetWeek As String
Set ws = Worksheets("Sheet1")
getdate = ws.Range("N1").Value
GetWeek = Int((Day(getdate) + 6) / 7)
Set rng1 = ws.Range("B1:F1")
Set rng2 = ws.Range("A2:A500")
For Each rng1cell In rng1
For Each rng2cell In rng2
If rng1cell = GetWeek And rng2cell = Format(getdate, "yyyy-mmm") Then
'Copy value and paste into Sheet1.Range("M2")
End If
Next rng1cell
Next rng2cell
End Sub
Here are the dates which needs to match with table and get relevant the value.
5/13/2021
5/16/2021
5/19/2021
5/22/2021
5/25/2021
5/28/2021
5/31/2021
6/3/2021
6/6/2021
6/9/2021
6/12/2021
6/15/2021
6/18/2021
6/21/2021
6/24/2021
Non-VBA Method
One way this could be done without using VBA is with a INDEX/MATCH formula.
The following formula assumes the data is in B2:F500, the month/years are in A2:A500, the weeks in B1:F1 and the dates to look for are in column N, all on the same sheet Sheet1.
=INDEX($B$2:$F$13,MATCH(TEXT(N1,"yyyy-mmm"),Sheet1!$A$2:$A$13,0),MATCH(INT((DAY(N1)+6)/7),Sheet1!$B$1:$F$1,0))
VBA Method
If you want VBA to do this here's one way.
Option Explicit
Sub findMatchingRecords()
Dim ws As Worksheet
Dim rngData As Range
Dim rngDates As Range
Dim arrData As Variant
Dim arrDates As Variant
Dim arrYearMonth As Variant
Dim arrValues As Variant
Dim arrWeeks As Variant
Dim Res As Variant
Dim idxCol As Long
Dim idxDate As Long
Dim idxRow As Long
Dim wk As Long
Set ws = Sheets("Sheet1")
With ws
Set rngData = .Range("A1").CurrentRegion
Set rngDates = .Range("N1", .Range("N" & Rows.Count).End(xlUp))
End With
With rngData
arrData = rngData.Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
arrYearMonth = .Columns(1).Offset(1).Resize(.Rows.Count - 1)
arrWeeks = .Rows(1).Offset(, 1).Resize(, .Columns.Count - 1)
End With
arrDates = rngDates.Value
ReDim arrValues(1 To UBound(arrDates, 1), 1 To 1)
For idxDate = LBound(arrDates, 1) To UBound(arrDates, 1)
idxRow = 0
idxCol = 0
Res = Application.Match(Format(arrDates(idxDate, 1), "yyyy-mmm"), arrYearMonth, 0)
If Not IsError(Res) Then
idxRow = Res
wk = Int((Day(arrDates(idxDate, 1)) + 6) / 7)
Res = Application.Match(wk, arrWeeks, 0)
If Not IsError(Res) Then
idxCol = Res
End If
End If
If idxRow <> 0 And idxCol <> 0 Then
arrValues(idxDate, 1) = arrData(idxRow, idxCol)
End If
Next idxDate
rngDates.Offset(, 1).Value = arrValues
End Sub
Please, test the next code:
Sub MatchDate_WeekNo()
Dim sh As Worksheet, lastR As Long, arr, arrN, arrfin, i As Long, strDate As String
Dim weekN As Long, arrRow, arrCol, iCol As Variant, iRow As Variant, lastRN As Long
Set sh = Worksheets("Sheet1")
lastR = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
lastRN = sh.Range("N" & sh.Rows.Count).End(xlUp).Row
arr = sh.Range("A1:F" & lastR).Value
arrRow = Application.Index(arr, 1, 0)
arrCol = Application.Transpose(Application.Index(arr, 0, 1))
arrN = sh.Range("N2:N" & lastRN).Value2
ReDim arrfin(1 To UBound(arrN), 1 To 1)
For i = 1 To UBound(arrN)
strDate = StringFromDate(CDate(arrN(i, 1)))
weekN = Int((Day(arrN(i, 1)) + 6) / 7)
iCol = Application.Match(weekN, arrRow, 0)
iRow = Application.Match(strDate, arrCol, 0)
If IsNumeric(iCol) And IsNumeric(iRow) Then
arrfin(i, 1) = arr(iRow, iCol)
End If
Next i
'drop the final array content:
sh.Range("O2").Resize(UBound(arrfin), 1).Value = arrfin
End Sub
Function StringFromDate(d As Date) As String
Dim arrM
Const strMonths As String = "Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec"
arrM = Split(strMonths, ",")
StringFromDate = Year(d) & "-" & Application.Index(arrM, Month(d))
End Function
Format(arrDates(idxDate, 1), "yyyy-mmm") does not return the month in case of localization different then English type and only that's why I am using a function...
I am populating a array with values from part of a column (range). The resulting array is multidimensional - but it should be one dimensional. I want to get just Emp ID values into the array:
I have tried this :
Sub Test()
Dim colPostionNumber As Integer
Dim lastRow As Integer
Dim ws As Worksheet
Dim positionNumberArray As Variant
Set ws = ActiveSheet
With ActiveWorkbook.Sheets("Sheet 1")
colPositionNumber = Application.WorksheetFunction.Match("Emp ID", ws.Rows(5), 0)
lastRow = ws.UsedRange.SpecialCells(xlCellTypeLastCell).row
positionNumberArray = .Range(Cells(5, colPositionNumber), Cells(lastRow, colPositionNumber)).Value
End With
End Sub
But the resulting array is two dimensional
I tried reDim but that didn't work. How do I do this with a one dimensional array?
Write One-Column 2D Array to 1D Array
To get a zero-based 1D array, you will have to loop.
Sub Test()
Dim colPositionNumber As Long
Dim lastRow As Long
Dim ws As Worksheet
Dim Data As Variant
Dim positionNumberArray As Variant
Set ws = ActiveSheet
With ActiveWorkbook.Sheets("Sheet 1")
colPositionNumber = Application.Match("Emp ID", ws.Rows(5), 0)
lastRow = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Data = .Range(.Cells(5, colPositionNumber), _
.Cells(lastRow, colPositionNumber)).Value
ReDim positionNumberArray(UBound(Data, 1) - 1)
Dim n As Long
For n = 1 To UBound(Data, 1)
positionNumberArray(n - 1) = Data(n, 1)
Next n
End With
End Sub
Using Application.Transpose
The following procedures show how to write a one-column or a one-row range to a one-based 1D array:
Sub testATColumn()
Dim rg As Range: Set rg = Range("A1:A5")
Dim arr As Variant: arr = Application.Transpose(rg.Value)
Debug.Print LBound(arr, 1), UBound(arr, 1)
On Error Resume Next
Debug.Print LBound(arr, 2), UBound(arr, 2)
On Error GoTo 0
End Sub
Sub testATRow()
Dim rg As Range: Set rg = Range("A1:E1")
Dim arr As Variant
arr = Application.Transpose(Application.Transpose(rg.Value))
Debug.Print LBound(arr, 1), UBound(arr, 1)
On Error Resume Next
Debug.Print LBound(arr, 2), UBound(arr, 2)
On Error GoTo 0
End Sub
Note that Application.Transpose has a limit of 65535 elements per dimension.
Reduce dimension via Excel function ArrayToText()
If you dispose of version MS 365 you could try the following approach via Excel function ArrayToText() and an eventual split action.
Sub reduceDim()
Dim t#: t = Timer
Dim rng As Range
Set rng = Sheet1.Range("B2:B7") ' << change to your needs
Dim data
data = Split(Evaluate("ArrayToText(" & rng.Address(False, False, External:=True) & ")"), ", ")
Debug.Print "Array(" & LBound(data) & " To " & UBound(data) & ")"
Debug.Print Join(data, "|") ' display resulting 0-based 1-dim array elements
Debug.Print Format(Timer - t, "0.00 secs")
End Sub
Output in VB Editor's immediate window
Array(0 To 5)
1|2|3|4|5|6
0,00 secs
I am trying to iterate through an array using:-
For i = LBound(arr, 1) To UBound(arr, 1)
Debug.Print arr(i, 1)
Next i
but receive a Subscript out of range error at Debug.Print arr(i, 1) which I do not understand. The code works fine if I take out the above lines.
Sub Summarise()
Dim dict
Dim i As Long
Dim arr() As Variant
Dim n As Long
Dim ws As Worksheet
Dim ws2 As Worksheet
Set ws2 = Worksheets("Plan")
Set ws = Worksheets("Data")
dict = ws.[A1].CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(dict, 1)
.Item(dict(i, 1)) = .Item(dict(i, 1)) + dict(i, 5)
Next
arr = Array(.Keys, .items)
n = .Count
End With
For i = LBound(arr, 1) To UBound(arr, 1)
Debug.Print arr(i, 1)
Next i
ws2.[A1].CurrentRegion.ClearContents
ws2.[A1].Resize(n, 2).Value = Application.Transpose(arr)
End Sub
Your line arr = Array(.Keys, .items) is creating an array of arrays and not an array of those items.
i.e. Array(Array(1,2,3), Array(4,5,6))
To loop through this you would need to do something like
For i = LBound(arr, 1) To UBound(arr, 1)
For j = LBound(arr(i)) to UBound(arr(i))
Debug.Print arr(i)(j)
Next j
Next i
To avoid doing this and loop through as you're currently you could add to your array as you add to your dictionary