I have two lists of Data. List A and B both contain letter grades. I want to compare the data and if both lists have the same letter, I want to move that letter to list C that is blank to start with. If the two lists do not have the same letter, keep the letter where it is. I want to use 2 arrays to store the data and then create three new arrays for new list a,b, and c. Here is what I have so far.
Sub example1()
Dim ListA As Range, ListB As Range, ListC As Range
Range("H4:H10").Name = "ListA"
Range("I4:I6").Name = "ListB"
Range("J4", Range("J4").End(xlDown)).Name = "ListC"
Dim A(1 To 7), B(1 To 3), i As Integer, j As Integer
For i = 1 To 7 'stores data in listA in array A
A(i) = Range("ListA").Cells(i)
Next
For j = 1 To 3 'stores data in listB in array B
B(j) = Range("ListB").Cells(j)
Next
'select first from ListA and then compare data to listB
' if it is not found, stop and go to next item
'if it IS found, put in list C
Dim isfound As Boolean, letter As Variant, C(1 To 7), k As Integer
For i = 1 To 7
isfound = False
For j = 1 To 3
If A(i) = B(j) Then
isfound = True
letter = A(i)
Exit For
End If
Next
For k = 1 To 7
C(k) = Range("ListC").Cells(k) 'this is the part I am stuck on. How
do I get data to paste over to List C?
If isfound = True Then
C(k) = A(i) 'this says it will be equal to A(i) value if it is
found.
End If
Next
Next
End Sub
Something like this would work:
Sub example1()
Dim ListA, ListB, ListC(), i As Long, n As Long, m
ListA = Range("H4:H10").Value
ListB = Range("I4:I8").Value
ReDim ListC(1 To UBound(ListA, 1), 1 To 1) 'size the "dups" array
n = 1
For i = 1 To UBound(ListA, 1)
m = Application.Match(ListA(i, 1), ListB, 0) '<< check for match
If Not IsError(m) Then '<< have a duplicate
ListC(n, 1) = ListA(i, 1) 'add to ListC
ListA(i, 1) = "" '(optional) remove from original lists...
ListB(m, 1) = ""
n = n + 1
End If
Next i
'print to sheet...
Range("K4").Resize(UBound(ListA, 1)).Value = Compact(ListA)
Range("L4").Resize(UBound(ListB, 1)).Value = Compact(ListB)
Range("M4").Resize(UBound(ListC, 1)).Value = Compact(ListC)
End Sub
'remove empty array locations...
Function Compact(arr)
Dim rv(), p As Long, i As Long
ReDim rv(1 To UBound(arr, 1), 1 To 1)
For i = 1 To UBound(arr, 1)
If Len(arr(i, 1)) > 0 Then
p = p + 1
rv(p, 1) = arr(i, 1)
End If
Next i
Compact = rv
End Function
This assumes listA/B each contains unique values (no repeats within one list)
Related
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
I am trying to write a simple randomizing program that reads from a column of names and randomly writes them to three columns of four. I have something that kind of works, but it is duplicating my names and I can figure out how to fix it with arrays or collections as those wont let me compare values. Thank you in advance.
Goal: randomization without doubling up two names
Problem: comparing and writing (to worksheet) collection and/or arrays
Option Explicit
Private Sub Randomize_Click()
Dim HowMany As Integer
Dim NoOfNames As Long
Dim RandomNumber As Integer
Dim Names(), dub() As String 'Array to store randomly selected names
Dim i, j, r, a, p As Byte
Dim CellsOut As Long 'Variable to be used when entering names onto worksheet
Dim ArI As Byte 'Variable to increment through array indexes
Application.ScreenUpdating = False
HowMany = 4 ' use with a third loops?
CellsOut = 4
For a = 1 To 6
For r = 1 To 3
For j = 2 To 5
'CellsOut = i 'turn this into loops
ReDim Names(1 To 4) 'Set the array size to how many names required
NoOfNames = Application.CountA(Worksheets("Employees").Range("A:A")) - 1 ' Find how many
names in the list
i = 1
Do While i <= HowMany
RandomNo:
RandomNumber = Application.RandBetween(2, NoOfNames + 1)
dub = RandomNumber
'dub.Add Unit.Value
If Names(i) = Cells(RandomNumber, 1).Value Then
'If Names(i) = dub(Unit) Then
GoTo RandomNo
End If
Names(i) = Worksheets("Employees").Cells(RandomNumber, 1).Value ' Assign random
name to the array
i = i + 1 '
Loop
'Loop through the array and enter names onto the worksheet
For ArI = LBound(Names) To UBound(Names)
Cells(CellsOut, j) = Names(ArI)
CellsOut = CellsOut + 1
Next ArI
Application.ScreenUpdating = True
CellsOut = 4
Next j
Next r
Next a
End Sub
Display
Names
Random Names
Current Setup
This solution uses the dictionary to randomize numbers which I was exploring earlier today.
The complete code goes into a standard module.
Adjust the three constants at the beginning of randomizeNames.
You only run randomizeNames, e.g. via a command button:
Private Sub Randomize_Click()
randomizeNames
End Sub
The Code
Option Explicit
Sub randomizeNames()
' Constants
Const srcFirst As String = "A2"
Const NoC As Long = 3
Const tgtFirst As String = "C2"
' Define Source First Cell Range ('cel').
Dim cel As Range
Set cel = Range(srcFirst)
' Define Source Last Cell Range ('rng').
Dim rng As Range
Set rng = Cells(Rows.Count, cel.Column).End(xlUp)
' Define Source Column Range ('rng').
Set rng = Range(cel, rng)
' Define Number of Elements (names) ('NoE').
Dim NoE As Long
NoE = rng.Rows.Count
' Write values from Source Column Range to Source Array ('Source').
Dim Source As Variant
If NoE > 1 Then
Source = rng.Value
Else
ReDim Source(1 To 1, 1 To 1)
Source(1, 1) = rng.Value
End If
' Define Random Numbers Array ('RNA').
Dim RNA As Variant
' This line uses both functions.
RNA = getDictionary(Dictionary:=getRandomDictionary(1, NoE), _
FirstOnly:=True)
' Instead of numbers, write elements from Source Array
' to Random Number Array (Random Names Array).
Dim i As Long
For i = 1 To NoE
RNA(i, 1) = Source(RNA(i, 1), 1)
Next i
' Define Number of Rows in Target Array ('NoR') and the Remainder
' of elements ('Remainder').
Dim NoR As Long
NoR = Int(NoE / NoC)
Dim Remainder As Long
Remainder = NoE Mod NoC
If Remainder > 0 Then
NoR = NoR + 1
Else
Remainder = NoC
End If
' Define Target Array ('Target').
Dim Target As Variant
ReDim Target(1 To NoR, 1 To NoC)
' Declare additional variables.
Dim j As Long ' Target Array Columns Counter
Dim k As Long ' Random Names Array Rows Counter
' Write values from Random Names Array to Target Array.
For i = 1 To NoR - 1
For j = 1 To NoC
k = k + 1
Target(i, j) = RNA(k, 1)
Next j
Next i
For j = 1 To Remainder
k = k + 1
Target(i, j) = RNA(k, 1)
Next j
' Define Target First Cell Range ('cel').
Set cel = Range(tgtFirst)
' Clear contents from Target First Cell Range to bottom-most cell
' of last column of Target Range.
cel.Resize(Rows.Count - cel.Row + 1, NoC).ClearContents
' Write values from Target Array to Target Range.
Range(tgtFirst).Resize(NoR, NoC).Value = Target
End Sub
Function getRandomDictionary(ByVal LowOrHigh As Long, _
ByVal HighOrLow As Long) _
As Object
' Define Numbers Dictionary ('dict').
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
' Define the lower number ('Minimum') and the Number of Elements ('NoE').
Dim NoE As Long
Dim Minimum As Long
If LowOrHigh < HighOrLow Then
Minimum = LowOrHigh
NoE = HighOrLow - LowOrHigh + 1
Else
Minimum = HighOrLow
NoE = LowOrHigh - HighOrLow + 1
End If
' Write random list of numbers to Numbers Dictionary.
Dim Current As Long
Do
' Randomize ' Takes considerably longer.
Current = Int(Minimum + NoE * Rnd)
dict(Current) = Empty
Loop Until dict.Count = NoE
' Write result.
Set getRandomDictionary = dict
End Function
Function getDictionary(Dictionary As Object, _
Optional ByVal Horizontal As Boolean = False, _
Optional ByVal FirstOnly As Boolean = False, _
Optional ByVal Flip As Boolean = False) _
As Variant
' Validate Dictionary.
If Dictionary Is Nothing Then
GoTo ProcExit
End If
Dim NoE As Long
NoE = Dictionary.Count
If NoE = 0 Then
GoTo ProcExit
End If
' Write values from Dictionary to Data Array ('Data').
Dim Data As Variant
Dim Key As Variant
Dim i As Long
If Not Horizontal Then
If Not FirstOnly Then
ReDim Data(1 To NoE, 1 To 2)
If Not Flip Then
For Each Key In Dictionary.Keys
i = i + 1
Data(i, 1) = Key
Data(i, 2) = Dictionary(Key)
Next Key
Else
For Each Key In Dictionary.Keys
i = i + 1
Data(i, 1) = Dictionary(Key)
Data(i, 2) = Key
Next Key
End If
Else
ReDim Data(1 To NoE, 1 To 1)
If Not Flip Then
For Each Key In Dictionary.Keys
i = i + 1
Data(i, 1) = Key
Next Key
Else
For Each Key In Dictionary.Keys
i = i + 1
Data(i, 1) = Dictionary(Key)
Next Key
End If
End If
Else
If Not FirstOnly Then
ReDim Data(1 To 2, 1 To NoE)
If Not Flip Then
For Each Key In Dictionary.Keys
i = i + 1
Data(1, i) = Key
Data(2, i) = Dictionary(Key)
Next Key
Else
For Each Key In Dictionary.Keys
i = i + 1
Data(1, i) = Dictionary(Key)
Data(2, i) = Key
Next Key
End If
Else
ReDim Data(1 To 1, 1 To NoE)
If Not Flip Then
For Each Key In Dictionary.Keys
i = i + 1
Data(1, i) = Key
Next Key
Else
For Each Key In Dictionary.Keys
i = i + 1
Data(1, i) = Dictionary(Key)
Next Key
End If
End If
End If
' Write result.
getDictionary = Data
ProcExit:
End Function
List of US Top 30 Names
James
John
Robert
Michael
William
Mary
David
Joseph
Richard
Charles
Thomas
Christopher
Daniel
Elizabeth
Matthew
Patricia
George
Jennifer
Linda
Anthony
Barbara
Donald
Paul
Mark
Andrew
Edward
Steven
Kenneth
Margaret
Joshua
I have a list of data displayed on a listbox, after clicking on a button the list appears on my userform.
I have dates on column 2 of my list, I want to do a descending sorting.
I have the code bellow but it's not working, am I wrong ?
fin_col_Form_Init = Ws.Cells(6, 256).End(xlToLeft).Column
UF_Profil_Edit1.ListBox_Form_Init.ColumnCount = 2
UF_Profil_Edit1.ListBox_Form_Init.ColumnWidths = "300;100"
fin_col_Form_Init = Ws.Cells(6, 256).End(xlToLeft).Column
UF_Profil_Edit1.ListBox_Form_Init.ColumnCount = 2
UF_Profil_Edit1.ListBox_Form_Init.ColumnWidths = "300;100"
For i = 2 To fin_col_Form_Init
UF_Profil_Edit1.ListBox_Form_Init.AddItem Ws.Cells(6, i)
UF_Profil_Edit1.ListBox_Form_Init.List(UF_Profil_Edit1.ListBox_Form_Init.ListCount - 1, 1) = Ws.Cells(7, i)
Next i
Dim y, x As Integer
Dim MyList As Variant
With UF_Profil_Edit1.ListBox_Form_Init
For y = 0 To .ListCount - 1
For x = y To .ListCount - 1
If CDate(.List(x, 1)) > CDate(.List(y, 1)) Then
For c = 0 To 2
MyList = .List(x, c)
.List(x, c) = .List(y, c)
.List(y, c) = MyList
Next c
End If
Next x
.List(y, 2) = Format(.List(y, 2), "####.00")
Next y
End With
Try the next code, please:
Sub testSortListBox()
Dim i As Long, j As Long, sTemp As Date, sTemp2 As String, SortList As Variant
UF_Profil_Edit1.ListBox_Form_Init.ColumnCount = 2
UF_Profil_Edit1.ListBox_Form_Init.ColumnWidths = "300;100"
'Store the list in an array to be sorted:
SortList = UF_Profil_Edit1.ListBox_Form_Init.List
'Sort the array on the second column
For i = LBound(SortList, 1) To UBound(SortList, 1) - 1
For j = i + 1 To UBound(SortList, 1)
If CDate(SortList(i, 1)) < CDate(SortList(j, 1)) Then
'Swap the second value
sTemp = SortList(i, 1)
SortList(i, 1) = SortList(j, 1)
SortList(j, 1) = sTemp
'Swap the first value
sTemp2 = SortList(i, 0)
SortList(i, 0) = SortList(j, 0)
SortList(j, 0) = sTemp2
End If
Next j
Next i
'Remove the contents of the listbox:
UF_Profil_Edit1.ListBox_Form_Init.Clear
'Load the sorted array in the list box:
UF_Profil_Edit1.ListBox_Form_Init.List = SortList
End Sub
But, please note: The list box in discussion must not be linked to a range (not being load by its RowSource property...
I have a small VBA Loop but it takes over 2-3 minute to finish, any idea how I can speed up/rewrite it that it will be faster?
The Range "Replace Names" is a List of 500 names of named areas in "Data".
The for loop searches for the one that matches the name in "Data" and replaces the one with the name from "Source". This also works fine, but it takes a while. Is there a faster method?
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For Each ID_name In wsSupport.Range("ReplaceNames")
wsCheck.Range("Data").Replace ID_name, wsSource.Range(ID_name), xlWhole
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
You might benefit from this valuable piece of text:
https://www.microsoft.com/en-us/microsoft-365/blog/2009/03/12/excel-vba-performance-coding-best-practices/
So in your case the Code could somewhat look like this:
Dim arrData as Variant, arrSource as Variant, k as long
arrData = wsCheck.Range("Data").value2 'this creates a two-dimensional array with rows on the first and columns on the second index
arrSource = wsSource.Range(...).value2
'loop through rows I suppose
for k = LBound(arrData,1) to UBound(arrData,1)
if arrData(k, yourColumn) = ... then
arrData(k, yourColumn) = arrSource(rowhere, columnhere)
endif
next k
wscheck.range("Data") = arrData
Its working now!!!
If you see mistakes let me know!
Dim arrData As Variant, arrSource As Variant, arrNames As Variant, k As Long
arrData = wsChecklist.Range("Checklist").Value2 'this creates a two-dimensional array with rows on the first and columns on the second index
arrSource = wsSupport.Range("ReplaceNames").Value2
arrNames = wsNia.Range("D1:D1000").Value2
'loop through rows I suppose
For k = LBound(arrData, 1) To UBound(arrData, 1)
For j = LBound(arrData, 2) To UBound(arrData, 2)
' If UCase(arrData(k, j)) = UCase(arrSource(x, 1)) Then
If UCase(arrSource(x, 1)) = UCase(arrData(k, j)) Then
For i = 1 To 1000
Name1 = wsNia.Cells(i, 2)
Name2 = wsNia.Cells(i, 3)
Name = Name1 & "_" & Name2
If UCase(arrData(k, j)) = UCase(Name) Then
arrData(k, j) = arrNames(i, 1)
x = x + 1
k = 1
j = 1
i = 1
Exit For
End If
Next i
End If
If k > 2900 And x < 265 Then
x = x + 1
j = 1
k = 1
End If
Next j
Next k
wsChecklist.Range("Checklist").Value2 = arrData
The code below extracts & format values from the range B6:E6, and then stores them in the variable. Afterwards, the routine sorts the collection of 4 variables in the ascending order. When sorted they're being put into the range L31:O31.
The problem is that if there are less than 4 variables selected, say 3, the routine will skip L31 cell, and put the rest to M31:O31. Whilst it should be input as L31:N31, and O31 - blank.
How can the code be modified to make it fulfill the data starting from L31 if less than 4 variables are in the collection?
Function ExtractKey(s As Variant) As Long
Dim v As Variant, n As Long
v = Trim(s) 'remove spaces leave only spaces between words
If v Like "*(*)" Then 'if it's SOPXX (YYYY) then
n = Len(v) 'find number of the characters
If n = 11 Then
v = Mid(v, n - 7, 7) 'find the number of SOP + year in bracket
ElseIf n = 12 Then
v = Mid(v, n - 8, 8)
End If
v = Replace(v, "(", "") 'replace the brackets with nothing
v = Replace(v, " ", "")
'SOP10 (2015) doesn't have to go first before SOP12 (2014); switch figures
If n = 11 Then
v = Right(v, 4) + Left(v, 1)
ElseIf n = 12 Then
v = Right(v, 4) + Left(v, 2)
End If
ExtractKey = CLng(v)
Else
ExtractKey = 0
End If
End Function
Sub Worksheet_Delta_Update()
Dim SourceRange As Range, TargetRange As Range
Dim i As Long, j As Long, minKey As Long, minAt As Long
Dim v As Variant
Dim C As New Collection
Set SourceRange = Worksheets("t").Range("B6:E6")
Set TargetRange = Worksheets("x").Range("L31:O31")
For i = 1 To 4
v = SourceRange.Cells(1, i).Value
C.Add Array(ExtractKey(v), v)
Next i
'transfer data
For i = 1 To 4
minAt = -1
For j = 1 To C.Count
If minAt = -1 Or C(j)(0) < minKey Then
minKey = C(j)(0)
minAt = j
End If
Next j
TargetRange.Cells(1, i).Value = C(minAt)(1)
C.Remove minAt
Next i
End Sub
You could add one variable e.g. col which will be used instead of variable i when the value is inserted into TargetRange. This variable will work the same way as the i works but it will be incremented only when the value which is inserted is not empty. HTH
'transfer data
Dim col As Integer
col = 1
For i = 1 To 4
minAt = -1
For j = 1 To C.Count
If minAt = -1 Or C(j)(0) < minKey Then
minKey = C(j)(0)
minAt = j
End If
Next j
If (C(minAt)(1) <> "") Then
TargetRange.Cells(1, col).Value = C(minAt)(1)
col = col + 1
End If
C.Remove minAt
Next i