I'm trying to print the contents of a dictionary of arrays in one fell swoop to an Excel sheet.
The dictionary structure may be something like this:
dict(company_name) = employee
Where employee is an array of three values, e.g., name, surname, and age.
As long as the items are single value, I can print the dictionary with a statement like
Cells(1, 1).Resize(dict.Count, 1).Value2 = Application.Transpose(dict.Keys)
Cells(1, 2).Resize(dict.Count, 1).Value2 = Application.Transpose(dict.Items)
I cannot come up with a solution when I have array as item.
You've got an error. dict.Keys - it's an array of the keys! You can't set the cell value as array
You need to set the string variable and collect all keys in it
Dim str1 as String
Dim str2 as String
For i=1 to count 'qty of elements in dictionary
str1=str1 & dict.Keys()(i)
str2=str2 & dict.Items()(i)
Next i
Here is the link to the article about dictionaries
http://www.snb-vba.eu/VBA_Dictionary_en.html
With a loop you can do something like this - should still be fast.
Sub DictOutput()
Dim dict As Object, i As Long, r As Long, cols As Long, col As Long, arr, data, k
Set dict = CreateObject("scripting.dictionary")
'load some test data
For i = 1 To 100
dict.Add "Key_" & Format(i, "000"), Split("A,B,C,D", ",")
Next i
arr = dict.Items()(0) 'get the first value
cols = 1 + (UBound(arr) - LBound(arr)) 'number of items in array (assumed all the same size)
ReDim data(1 To dict.Count, 1 To (1 + cols)) 'size the output array
r = 0
For Each k In dict 'loop and fill the output array
r = r + 1
data(r, 1) = k
arr = dict(k)
i = 2
For col = LBound(arr) To UBound(arr) 'loop array and populate output row
data(r, i) = arr(col)
i = i + 1
Next col
Next k
'put the data on the sheet
ActiveSheet.Range("A1").Resize(UBound(data, 1), UBound(data, 2)).Value = data
End Sub
Related
I have a set of matching values as shown:
The input is a table with Order number in the first column and dates in the seventh column.
I would like to extract all the matching dates from the seventh column and display only the 'unique dates' in the columns against each matching order value.
If there are no matching values in the input, it should return blank values in output.
I use Excel 2016. The inputs are in sheet 2.
I managed to get the dates with array index formula but it is slow with large data.
If you have access to the new array functions UNIQUE & FILTER then:
Using the sample data below
In cell E1: =UNIQUE(A1:A10)
In cell F1: =TRANSPOSE(UNIQUE(FILTER(B1:B10,A1:A10=E1)))
Then drag the formula from F1 down to the last cell which will populate your desired table.
Please, try the next VBA solution. It should be very fast, using two dictionaries and arrays, mostly working in memory. It will return the processed result starting from "J2" cell. It can return anywhere, you should only change "J2" cell with the cell range you need, even being in another sheet:
Sub extractUniqueValues_Dat()
Dim sh As Worksheet, lastR As Long, arr, arrIt, arrFin, Z As Long
Dim dict As Object, dictI As Object, i As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
arr = sh.Range("A2:G" & lastR).value 'place the range to be processed in an array, for faster iteration
Set dict = CreateObject("Scripting.Dictionary") 'set first necessary dictionary
For i = 1 To UBound(arr) 'iterate between the array rows and load the dictionary:
If Not dict.Exists(arr(i, 1)) Then 'if the key does not exist:
Set dictI = CreateObject("Scripting.Dictionary") 'set a new dictionary
dictI.Add arr(i, 7), vbNullString 'create a key of the new dictionary using first Date occurrence
dict.Add arr(i, 1), dictI 'create a dictionary key as Value and add the new dictionary as item
If dictI.count > Z Then Z = dictI.count 'extract maximum number of Date occurrences
Else
dict(arr(i, 1))(arr(i, 7)) = vbNullString 'if the key of the item dictionary does not exist it is added, with an empty item
If dict(arr(i, 1)).count > Z Then Z = dict(arr(i, 1)).count 'extract maximum number of Date occurrences
End If
Next i
ReDim arrFin(1 To dict.count, 1 To Z + 1) '+ 1, to make place for the dictionary key (in first column)
'fill the arrFin array:
For i = 0 To dict.count - 1
arrFin(i + 1, 1) = dict.Keys()(i) 'place the main dictionary key in the first column of the final array
For k = 1 To dict.Items()(i).count
arrFin(i + 1, 1 + k) = dict.Items()(i).Keys()(k - 1) 'place each date (extracted from the item dictionary keys) in the following columns
Next k
Next i
'build the header:
Dim arrH: arrH = Evaluate("TRANSPOSE(ROW(1:" & Z & "))")
arrH = Split("Match Value|Data " & Join(arrH, "|Data "), "|")
'drop the final aray content and apply a little formatting:
With sh.Range("J2").Resize(UBound(arrFin), UBound(arrFin, 2))
.value = arrFin
With .rows(1).Offset(-1)
.value = arrH
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
MsgBox "Ready..."
End Sub
Please send some feedback after testing it.
Edited:
Please, test the next version. It will work even if the customer orders will not be unique (in K:K column)... This code will also extract only unique values from the mentioned range. It will also check if there are values in the processed sheet which cannot be found in K:K, and returns in the sheet being processed, starting from "M1". Please, use the real sheet where K:K necessary column exists, when set shK sheet!
Private Sub extractUniqueValues_Dat()
Dim shK As Worksheet, lastRK As Long, sh As Worksheet, lastR As Long, arr, arrK, arrIt, arrFin, Z As Long
Dim dict As Object, dictI As Object, dictK As Object, i As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row 'last row in B:B
arr = sh.Range("B2:H" & lastR).Value 'place the range to be processed in an array, for faster iteration
Set shK = Worksheets("sheet KK") 'use here the necessary sheet (with values in K:K)!!!
lastRK = shK.Range("K" & shK.rows.count).End(xlUp).row 'last row in K:K
arrK = shK.Range("K2:K" & lastRK).Value
Set dictK = CreateObject("Scripting.Dictionary") 'set first necessary dictionary
Set dict = CreateObject("Scripting.Dictionary") 'set first necessary dictionary
'place the UNIQUE values in a dictionary, as keys and all unique date, for all accurrences in an item array:
For i = 1 To UBound(arr) 'iterate between the array rows and load the dictionary:
If Not dict.Exists(arr(i, 1)) Then 'if the key does not exist:
Set dictI = CreateObject("Scripting.Dictionary") 'set a new dictionary
dictI.Add arr(i, 7), vbNullString 'create a key of the new dictionary using first Date occurrence
dict.Add arr(i, 1), dictI 'create a dictionary key as Value and add the new dictionary as item
If dictI.count > Z Then Z = dictI.count 'extract maximum number of Date occurrences
Else
dict(arr(i, 1))(arr(i, 7)) = vbNullString 'if the key of the item dictinary does not exist it is added, with an empty item
If dict(arr(i, 1)).count > Z Then Z = dict(arr(i, 1)).count 'extract maximum number of Date occurrences
End If
Next i
'place the UNIQUE vales from K:K column, only as keys:
For i = 1 To UBound(arrK)
dictK(arrK(i, 1)) = vbNullString
Next i
ReDim arrFin(1 To dictK.count, 1 To Z + 3) '+ 1, to make splace for the dictionary key (in first column)
'fill the arrFin array:
For i = 0 To dictK.count - 1
arrFin(i + 1, 1) = dictK.Keys()(i) 'place the main dictionary keyi in the first column of the final array
If dict.Exists(dictK.Keys()(i)) Then
For k = 1 To dict(dictK.Keys()(i)).count
arrFin(i + 1, 3 + k) = dict(dictK.Keys()(i)).Keys()(k - 1) 'place each date (extracted from the item dictionary keys) in the following columns
Next k
End If
Next i
'check if there are missing values from sheet with processed data:
Dim arrMiss, KK As Long, boolMiss As Boolean
ReDim arrMiss(dict.count)
For i = 0 To dict.count - 1
If Not dictK.Exists(dict.Keys()(i)) Then
arrMiss(KK) = dict.Keys()(i): KK = KK + 1
End If
Next i
'build the header:
Dim arrH: arrH = Evaluate("TRANSPOSE(ROW(1:" & Z & "))")
arrH = Split("Match Value|x|y|Data " & Join(arrH, "|Data "), "|")
'drop the final aray content and apply a little formatting:
With sh.Range("M2").Resize(UBound(arrFin), UBound(arrFin, 2))
.CurrentRegion.Value = "" 'if the previous return dropped more rows than the actual one...
.Value = arrFin
With .rows(1).Offset(-1)
.Value = arrH
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
If KK > 0 Then
ReDim Preserve arrMiss(KK - 1)
MsgBox "Missing Values: " & vbCrLf & Join(arrMiss, vbCrLf), vbInformation, "Please, check..."
boolMiss = True
End If
If Not boolMiss Then MsgBox "Ready..."
End Sub
Send some feedback after testing it, please...
I have a code that converts a column from vertical state to horizontal (each group to be in one row)
Here's some dummy data
Groups Amount Notes Name
A 10 N1 GroupA
A 20 N2 GroupA
A 30 N3 GroupA
B 40 N4 GroupB
B 50 N5 GroupB
B 60 N6 GroupB
B 70 N7 GroupB
C 80 N8 GroupC
D 90 N9 GroupD
D 100 N10 GroupD
Here's the code that deals with the second column only
Sub Test()
Dim v, a, i As Long
v = Cells(1).CurrentRegion
ReDim b(UBound(v) + 1)
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(v)
a = .Item(v(i, 1))
If IsEmpty(a) Then a = b
a(0) = v(i, 1)
a(UBound(a)) = a(UBound(a)) + 1
a(a(UBound(a))) = v(i, 2)
.Item(v(i, 1)) = a
Next i
Range("G2").Resize(.Count, UBound(a) - 1) = Application.Index(.Items, 0)
End With
End Sub
The code works fine for the second column, but I need to deal with the third column too with the same idea. And as for the fourth column will be just once (in the output would be in one column)
Here's the expected output
The solution to your problem is a little more complicated than it first seems. But kudos to you for using a Dictionary rather than trying to do everything via arrays.
The code below uses a Dictionary whose keys are the values in the Groups column. The Item associated with these keys is an Arraylist. In turn, the Arraylist is populated with Arraylists comprising the Amount,Note and Nname values for each row corresponding to the Key in the Group Column. The Arraylist is used because we can easily delete items from An Arraylist.
Note that the Item method of Scripting.Dictionaries and ArrayLists is the default method, and for this reason I don't explicity invoke the Item method in the code. If the default method were something other than Item, then I would have specifically stated the default method.
The code below is a good deal longer than in your original post, but I will hope you will see how things have been split up into logical tasks.
You will also see that I use vertical spacing a lot to break codee withing methods into 'paragraphs'. This is a personal preference.
Public Sub Test2()
Dim myD As Scripting.Dictionary
Set myD = GetCurrentRegionAsDictionary(Cells(1).CurrentRegion)
Dim myArray As Variant
myArray = GetPopulatedOutputArray(myD)
Dim Destination As Range
Set Destination = Range("A20")
Destination.Resize(UBound(myArray, 1), UBound(myArray, 2)).Value = myArray
End Sub
'#Description("Returns an Array in the desired output format from the contents of the Scripting.Dictionary created from the CurrentRegion")
Public Function GetPopulatedOutputArray(ByRef ipD As Scripting.Dictionary) As Variant
Dim myAmountSpan As Long
myAmountSpan = MaxSubArrayListSize(ipD)
Dim myArray As Variant
ReDim myArray(1 To ipD.Count, 1 To 2 + myAmountSpan * 2)
Dim myHeaderText As Variant
myHeaderText = GetHeaderTextArray(ipD, myAmountSpan)
Dim myIndex As Long
For myIndex = 0 To UBound(myHeaderText)
myArray(1, myIndex + 1) = myHeaderText(myIndex)
Next
Dim myRow As Long
myRow = 2
Dim myKey As Variant
For Each myKey In ipD
myArray(myRow, 1) = myKey
Dim myCol As Long
myCol = 2
Dim myList As Variant
For Each myList In ipD(myKey)
myArray(myRow, myCol) = myList(0)
myArray(myRow, myCol + myAmountSpan) = myList(1)
If VBA.IsEmpty(myArray(myRow, UBound(myArray, 2))) Then
myArray(myRow, UBound(myArray, 2)) = myList(2)
End If
myCol = myCol + 1
Next
myRow = myRow + 1
Next
GetPopulatedOutputArray = myArray
End Function
'#Description("Returns an array contining the appropriately formatted header text")
Public Function GetHeaderTextArray(ByRef ipD As Scripting.Dictionary, ByVal ipAmountSpan As Long) As Variant
' The Scripting.Dictionary does not maintain order of addition
' so we need to search for a key longer than one character
Dim myFoundKey As String
Dim myHeaderList As ArrayList
Dim myKey As Variant
For Each myKey In ipD
If Len(myKey) > 2 Then
myFoundKey = myKey
Set myHeaderList = ipD(myKey)(0)
Exit For
End If
Next
Dim myT As String
myT = myFoundKey & ","
Dim myIndex As Long
For myIndex = 1 To ipAmountSpan
myT = myT & myHeaderList(0) & CStr(myIndex) & ","
Next
For myIndex = 1 To ipAmountSpan
myT = myT & myHeaderList(1) & CStr(myIndex) & ","
Next
myT = myT & myHeaderList(2)
' removeove the header text as it is no longer needed
ipD.Remove myFoundKey
GetHeaderTextArray = Split(myT, ",")
End Function
'#Description("Returns a Dictionary of arraylists using column 1 of the current region as the key
Public Function GetCurrentRegionAsDictionary(ByRef ipRange As Excel.Range) As Scripting.Dictionary
Dim myArray As Variant
myArray = ipRange.Value
Dim myD As Scripting.Dictionary
Set myD = New Scripting.Dictionary
Dim myRow As Long
For myRow = LBound(myArray, 1) To UBound(myArray, 1)
Dim myList As ArrayList
Set myList = GetRowAsList(myArray, myRow)
Dim myKey As Variant
Assign myKey, myList(0)
myList.RemoveAt 0
If Not myD.Exists(myKey) Then
myD.Add myKey, New ArrayList
End If
' Add an arraylist to the arraylist specified by Key
myD.Item(myKey).Add myList
Next
Set GetCurrentRegionAsDictionary = myD
End Function
'#Description("Get the size of largest subArrayList")
Public Function MaxSubArrayListSize(ByRef ipD As Scripting.Dictionary) As Long
Dim myMax As Long
myMax = 0
Dim myKey As Variant
For Each myKey In ipD
If ipD(myKey).Count > myMax Then
myMax = ipD(myKey).Count
End If
Next
MaxSubArrayListSize = myMax
End Function
'#Description("Returns a row of an Array as an ArrayList")
Public Function GetRowAsList(ByRef ipArray As Variant, ByVal ipRow As Long) As ArrayList
Dim myList As ArrayList
Set myList = New ArrayList
Dim myIndex As Long
For myIndex = LBound(ipArray, 2) To UBound(ipArray, 2)
myList.Add ipArray(ipRow, myIndex)
Next
Set GetRowAsList = myList
End Function
Public Sub Assign(ByRef ipTo As Variant, ByRef ipFrom As Variant)
If VBA.IsObject(ipFrom) Then
Set ipTo = ipFrom
Else
ipTo = ipFrom
End If
End Sub
I did it a little differently:
Sub ColsToRows()
Dim dict As Dictionary
Dim inner As Dictionary
Dim arr() As Variant
Dim arrNotExpand() As Variant
'add headers of columns you don't want to have expanded to array
arrNotExpand = Array("Name")
Dim myRange As Range
'set start of range you want to be converted; vals in first column will be used for keys in main dict
Set myRange = Range("A1").CurrentRegion
Dim Destination As Range
'set start destination range
Set Destination = Range("G1")
'creating main dict
Set dict = New Dictionary
'looping through all cells in first column (ex header)
For x = 2 To myRange.Rows.Count
'define key
dictKey = Cells(x, 1).Value
'check if key exists
If dict.Exists(dictKey) Then
'if exists, get innerKey, add val from each col to its inner dict
For y = 2 To myRange.Columns.Count
innerKey = Cells(1, y).Value
newVal = Cells(x, y).Value
'getting array from key, adding val to it, and reassigning updated array
arr = dict(dictKey)(innerKey)
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = newVal
dict(dictKey)(innerKey) = arr
Next y
Else
'key does not exist, create new inner dict
Set inner = New Dictionary
'add inner dict for each col, and assign first vals
For y = 2 To myRange.Columns.Count
innerKey = Cells(1, y).Value
newVal = Cells(x, y).Value
arr = Array(newVal)
inner.Add innerKey, arr
Next y
'add inner dict to main dict
dict.Add dictKey, inner
End If
Next x
'establish maxCols, i.e. the max length of any array for inner
maxCols = 1
'since we're retrieving the expanded version of arr for each inner, we can just check the first to get the maxCols val
For Each dictKey In dict.Keys
'checking lengthArray
lengthArray = UBound(dict(dictKey)(dict(dictKey).Keys()(1))) + 1
'if it is larger than prev stored val, use new length
If lengthArray > maxCols Then
maxCols = lengthArray
End If
Next dictKey
'convert dict to Destination
'header for keys main dict
Destination = myRange.Cells(1, 1)
'keep track of offset rows
countRow = 0
For Each dictKey In dict.Keys
'keep trach of offset cols
countCol = 0
For Each innerKey In dict(dictKey)
'if so, add the dictKey
If countCol = 0 Then
Destination.Offset(1 + countRow, 0) = dictKey
End If
'if innerKey not in arrNotExpand, we want use full array
If IsError(Application.Match(innerKey, arrNotExpand, 0)) Then
'if we are looking at the first key, also add the headers for each inner dict key
If countRow = 0 Then
For col = 1 To maxCols
'add increment for headers, e.g. "Amount1", "Amount2" etc. (replace necessary for getting rid of whitespace)
Destination.Offset(countRow, 1 + countCol + col - 1) = Replace(innerKey + Str(col), " ", "")
Next col
End If
'get length of arr for specific inner dict
lengthArray = UBound(dict(dictKey)(innerKey)) + 1
'use here for resizing and fill with array
Destination.Offset(1 + countRow, 1 + countCol).Resize(1, lengthArray) = dict(dictKey)(innerKey)
'adjust offset cols
countCol = countCol + maxCols
Else
'only True if the first innerKey is in arrNotExpand
If countRow = 0 Then
Destination.Offset(countRow, 1 + countCol) = innerKey
End If
'no expansion, so use only first val from array
Destination.Offset(1 + countRow, 1 + countCol) = dict(dictKey)(innerKey)(0)
'adjust offset col just by one
countCol = countCol + 1
End If
Next innerKey
'adjust offset row for next dict key
countRow = countRow + 1
Next dictKey
End Sub
Make sure to enter the correct references for Set myRange = Range("A1").CurrentRegion and Set Destination = Range("F1"). Add the headers for columns that you don't want to expand to this array : arrNotExpand = Array("Name"). As is, you'll get the expected output. Let's say you add "Amount" as well, so: arrNotExpand = Array("Amount", "Name"), then you'll get this:
If you add more columns to the range, this works. Just make sure that all your headers are unique (else you'll run into an error with assigning new dict.keys). Let me know if anything is unclear, or if you find a bug.
I have a dataset in which one of the columns needs to be filled conditionally. The conditions are that for equal lot numbers, the dates that are older (and equal) would be filled with 123ABC while dates that are newer (and equal) would be filled with 789XYZ. In the case of only one available date then it should be filled with 123ABC.
I tried the following code but it is filling the first 3 cells as 123ABC and rest of the cells as 789XYZ.
Please help.
Dim F As Worksheet
Set F = ThisWorkbook.Worksheets("Sheet1")
Dim i As Long: i = 0
Dim j As Long
Do While F.Range("C2").Offset(i, 0) <> ""
If F.Range("A2").Offset(i, 0) = "" Then
j = 0
Do While F.Range("C2").Offset(j, 0) <> ""
If (Abs(DateDiff("d", F.Range("C2").Offset(i, 0).Value, F.Range("C2").Offset(j, 0).Value)) <= 5) And (F.Range("B2").Offset(i, 0) = F.Range("B2").Offset(j, 0)) Then
F.Range("A2").Offset(i, 0).Value = "123ABC"
Else
F.Range("A2").Offset(i, 0).Value = "789XYZ"
GoTo Next_Blank
End If
j = j + 1
Loop
End If
Next_Blank:
i = i + 1
Loop
End Sub
Please, try the next approach. It should be very fast even for large ranges. It uses a dictionary to create "Lot" unique keys, keeping the value as the most recent Date. Then it uses arrays and works only in memory, dropping the processed array content at one, at the end of the code:
Sub FillColumn()
Dim sh As Worksheet, lastR As Long, arr, i As Long, arrFin, dict As Object
Const beforeD As String = "123ABC", maxD As String = "789XYZ"
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row 'last row in "B:B"
arr = sh.Range("A1:C" & lastR).value 'place the range in an array for faster iteration
'fill a dictionary with unique lots and most recent Date:
Set dict = CreateObject("scripting.Dictionary") 'set the necessary dictionary
For i = 2 To UBound(arr) 'iterate between the array row
'create dictionary unique keys with most recent Date as item:
dict(arr(i, 2)) = IIf(CDate(arr(i, 3)) > CDate(dict(arr(i, 2))), CDate(arr(i, 3)), CDate(arr(i, 3)))
Next i
arrFin = arr 'initialize arrFin as the initial one
For i = 2 To UBound(arr) 'iterate between the arr items
If CDate(arr(i, 3)) < dict(arr(i, 2)) Then 'for a Date before existing one in column B:B:
arrFin(i, 1) = beforeD 'place the string beforeD
Else
arrFin(i, 1) = maxD 'place the string maxD
End If
Next i
'drop the array content at once:
sh.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
End Sub
Edited:
Please, test the next version, which place "123ABC" if a single Date is found for the same "Lot", as required in your comment:
Sub FillColumn2()
Dim sh As Worksheet, lastR As Long, arr, i As Long, arrFin, dict As Object
Const beforeD As String = "123ABC", maxD As String = "789XYZ"
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
arr = sh.Range("A1:C" & lastR).value 'place the range in an array for faster iteration
'fill a dictionary with unique lots and most recent Date:
Set dict = CreateObject("scripting.Dictionary") 'set the necessary dictionary
Dim arrExist
For i = 2 To UBound(arr) 'iterate between the array row
'create dictionary unique keys with most recent Date as item, and False for only one Date found:
If Not dict.Exists(arr(i, 2)) Then
dict.Add arr(i, 2), Array(CDate(arr(i, 3)), False) 'False means only one Date
Else
If CDate(arr(i, 3)) > dict(arr(i, 2))(0) Then
arrExist = dict(arr(i, 2)) 'place existing dictionary item in an array (to be changed)
arrExist(0) = CDate(arr(i, 3)): arrExist(1) = True 'True means that a second graiter Date has been found
dict(arr(i, 2)) = arrExist
End If
End If
Next i
arrFin = arr 'initialize arrFin as the initial one
For i = 2 To UBound(arr) 'iterate between the arr items
If CDate(arr(i, 3)) < dict(arr(i, 2))(0) Or dict(arr(i, 2))(1) = False Then 'check also the second item array element (boolean)
arrFin(i, 1) = beforeD 'place the string beforeD, also for the case of the same date
Else
arrFin(i, 1) = maxD 'place the string maxD
End If
Next i
'drop the array content at once:
sh.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
End Sub
A dictionary can keep any data type, but it has a peculiarity: if the dictionary item is an array it cannot be modified directly in the item. That's why the code uses arrExist to take the dictionary item, modify it and place it back.
It is also good to know that Excel keeps a Date as a Long number. That's why comparing the existing dictionary item (when empty) with a lower number would never change the item. No date less then zero can be supplied...
I have some data (mixed data types in column A). How can I split each data type into another column?
I mean numbers to be in column, string in column, dates in column and so on
This is my try till now but I didn't get all the results as expected
Sub Test()
Dim a, b(), dic As Object, i As Long, k As Long, ii As Long, n As Long
a = Range("A1:A10").Value
Set dic = CreateObject("Scripting.Dictionary")
For i = LBound(a) To UBound(a)
If Not dic.Exists(VarType(a(i, 1))) Then
dic.Item(VarType(a(i, 1))) = Empty
ReDim Preserve b(UBound(a, 1), k)
k = k + 1
End If
n = 0
Do Until b(i - 1, k - 1) <> Empty
b(i - 1, k - 1) = a(i, 1)
Loop
Next i
Range("J1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
There are a number of things I would do differently in your code
using meaningful names for the variables
specifying the worksheet instead of depending on the implied ActiveSheet
clearing the results area on the worksheet
early binding of the dictionary object
dynamic determination of the range to be processed
etc
but the below code modifies your original code minimally, to obtain the output I think you want, based on your screenshot
Sub Test()
Dim a, b(), dic As Object, i As Long, k As Long, ii As Long, n As Long, v
Dim dataType As String
a = Range("A1:A10").Value
ReDim b(1 To UBound(a))
'first create the dictionary with the datatypes
'since you are maintaining the entries in the same rows,
' add an empty array as the item
Set dic = CreateObject("Scripting.Dictionary")
dic.Add Key:="number", Item:=b
dic.Add Key:="date", Item:=b
dic.Add Key:="string", Item:=b
dic.Add Key:="logical", Item:=b
'Add the values to the correct dictionary item
' at the correct spot in the array
For i = LBound(a) To UBound(a)
Select Case VarType(a(i, 1))
Case 2 To 6
dataType = "number"
Case 7
dataType = "date"
Case 8
dataType = "string"
Case 11
dataType = "logical"
Case Else
dataType = ""
End Select
If dataType <> "" Then
v = dic(dataType)
v(i) = a(i, 1)
dic(dataType) = v
End If
Next i
'Next create output array
ReDim b(1 To UBound(a), 1 To dic.Count)
k = 0
For Each v In dic.Keys
k = k + 1
For i = 1 To UBound(dic(v))
b(i, k) = dic(v)(i)
Next i
Next v
Range("J1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
Edit:
If, as you indicate in your comments, you don't want to set up the data types initially, you can also do that at the time of creation of the dictionary object. Using the same algorithm of storing the item as an array of the same size as the number of rows in the data base:
Sub Test()
Dim a, b(), dic As Object, i As Long, k As Long, ii As Long, n As Long, v
Dim dataType As Long
a = Range("A1:A10").Value
ReDim b(1 To UBound(a))
Set dic = CreateObject("Scripting.Dictionary")
'Add the values to the correct dictionary item
' at the correct spot in the array
For i = LBound(a) To UBound(a)
dataType = VarType(a(i, 1))
If a(i, 1) <> "" Then
If Not dic.Exists(dataType) Then
ReDim b(UBound(a))
b(i) = a(i, 1)
dic.Add Key:=dataType, Item:=b
Else
b = dic(dataType)
b(i) = a(i, 1)
dic(dataType) = b
End If
End If
Next i
'Next create output array
ReDim b(1 To UBound(a), 1 To dic.Count)
k = 0
For Each v In dic.Keys
k = k + 1
For i = 1 To UBound(dic(v))
b(i, k) = dic(v)(i)
Next i
Next v
Range("J1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
Please help
I am trying to perform the following:
I have an excel file 'A' with 50000 rows.
I am creating another excel 'B' with 150 rows.
The 150 rows are picked from file 'A'.
The row selection criteria is based on values of 5 different columns as this set
First I want to make sure I select the rows with all different combination of these 5 columns
If I run out of combinations then I can pick combination which are repeated as have to reach the 150
What I have achieved till now is selecting 150 random rows from excel A and pasted in excel B
records = 150
With DataWs
SourceLastRow = .Cells(.Rows.count, "B").End(xlUp).Row
.Rows(1).Copy DestinationWs.Cells(DestLastRow, "A")
ar = RandomNumber(2, SourceLastRow, Records)
For r = 2 To UBound(ar)
DestLastRow = DestLastRow + 1
.Rows(ar(r)).Copy DestinationWs.Cells(DestLastRow, "A")
Next r
End With
Function RandomNumber(Bottom As Long, Top As Long, Amount As Long) As Variant
Dim i As Long, r As Long, temp As Long
ReDim iArr(Bottom To Top) As Long
For i = Bottom To Top: iArr(i) = i: Next i
For i = 1 To Amount
r = Int(Rnd() * (Top - Bottom + 1 - (i - 1))) _
+ (Bottom + (i - 1))
temp = iArr(r): iArr(r) = iArr(Bottom + i - 1): _
iArr(Bottom + i - 1) = temp
Next i
ReDim Preserve iArr(Bottom To Bottom + Amount - 1)
RandomNumber = iArr
End Function
This is maybe a bit complex but worked for me:
Sub PickRows()
Const COPY_ROWS As Long = 150
Dim dict As Object, data, DataWS As Worksheet, DestWS As Worksheet
Dim numCopied As Long, r As Long, k As String, destRow As Long
Dim combo As Long, keys, col As Collection, theRow As Long, t
Set DataWS = Sheet2 'for example
Set DestWS = Sheet3 'for example
'get the source data (at least the part with the key columns) in an array
data = DataWS.Range("A1:E" & DataWS.Cells(DataWS.Rows.Count, "B").End(xlUp).Row).Value
Set dict = CreateObject("scripting.dictionary")
'fill the dictionary - keys are combined 5 columns, values are collection
' containing the row number for each source row with that key
For r = 2 To UBound(data, 1)
k = RowKey(data, r, Array(1, 2, 3, 4, 5)) 'combination of the 5 columns
If Not dict.exists(k) Then
dict.Add k, New Collection 'new combination?
End If
dict(k).Add r
Next r
numCopied = 0
combo = 0
destRow = 2
'loop over the various key column combinations and pick a row from each
' keep looping until we've copied enough rows
Do While numCopied < COPY_ROWS
'see here for why the extra ()
'https://stackoverflow.com/questions/26585884/runtime-error-with-dictionary-when-using-late-binding-but-not-early-binding
Set col = dict.Items()(combo) 'a collection of all rows for this particular key
theRow = RemoveRandom(col)
'edit line below to copy more columns (eg change 5 to 10)
DataWS.Cells(theRow, 1).Resize(1, 5).Copy DestWS.Cells(destRow, 1)
destRow = destRow + 1 'next destination row
If col.Count = 0 Then dict.Remove dict.keys()(combo) 'remove if no more rows for this key
If dict.Count = 0 Then Exit Do 'run out of any rows to pick? (should not happen...)
combo = combo + 1
If combo >= dict.Count Then combo = 0 'start looping again
numCopied = numCopied + 1
Loop
End Sub
'Create a composite key from columns in arrKeyCols
Function RowKey(data, rowNum, arrKeyCols) As String
Dim rv, i, sep
For i = LBound(arrKeyCols) To UBound(arrKeyCols)
rv = rv & sep & data(rowNum, arrKeyCols(i))
sep = "~~"
Next i
RowKey = rv
End Function
'select a random item from a collection, remove it, and return the value
Function RemoveRandom(col As Collection)
Dim rv, num As Long
num = Application.RandBetween(1, col.Count)
RemoveRandom = col(num)
col.Remove num
End Function