VBA - example with arrays, checkboxes etc.

[vbalad]

Hi all,

I am a beginner in VBA.
In the example attached ( there are an unspecified number of codes and groups)
I need:
1. how to collect the codes belonging to a given group into an array or arrays, but into a range or ranges .
2. make columns for the groups in the new sheets created
3 . I need to assign a macro to the button "Check Checkboxes for Group" that will check the checkboxes in column A for a given group, as well as the possibility of selecting the group after entering in the InputBox

It seems to me that I need for point 1. an option to an array or arrays, because if I need to in new sheets columns for groups, I would like that within the workbook the group membership of the codes is remembered

Regards

 

[Domenic]

Okay, so I have amended the code so that it places the results on the same worksheet as the source data, starting at E2...

Option Explicit

Sub test()

    Const TextCompare As Long = 1

    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Worksheets("Sheet1") 'change the sheet name accordingly
    
    Dim lastRow As Long
    With wsSource
        lastRow = .Cells(.Rows.count, "C").End(xlUp).Row
    End With
    
    If lastRow < 2 Then
        MsgBox "No data found!", vbExclamation
        Exit Sub
    End If
    
    Dim Data As Variant
    Data = wsSource.Range("B2:C" & lastRow).Value
    
    'create a dictionary to store key/value pair
    'group stored as key, and array containing corresponding codes stored as value
    Dim dicCodesByGroup As Object
    Set dicCodesByGroup = CreateObject("Scripting.Dictionary")
    dicCodesByGroup.CompareMode = TextCompare
    
    'get a list of unique groups
    Dim i As Long
    For i = LBound(Data, 1) To UBound(Data, 1)
        dicCodesByGroup(Data(i, 2)) = ""
    Next i
    
    'for each group in the dictionary, get an array of corresponding codes, and add it to the dictionary
    Dim key As Variant
    Dim codes As Variant
    For Each key In dicCodesByGroup
        codes = getCodesByGroup(Data, key)
         dicCodesByGroup(key) = codes
    Next key
    
    'for each group in the dictionary, get the corresponding array, etc
    Dim key2 As Variant
    Dim group As String
    Dim codes2 As Variant
    Dim rw As Long
    rw = 2
    For Each key2 In dicCodesByGroup
        group = key2
        codes2 = dicCodesByGroup(key2)
        With wsSource
            .Range("E" & rw).Value = group
            .Range("F" & rw).Resize(, UBound(codes2, 1)).Value = codes2
        End With
        rw = rw + 1
    Next key2

End Sub

Private Function getCodesByGroup(ByRef Data As Variant, ByVal group As String) As Variant

    ReDim codes(1 To UBound(Data, 1)) As Long
    
    Dim count As Long
    Dim i As Long
    
    count = 0
    For i = LBound(Data, 1) To UBound(Data, 1)
        If LCase(Data(i, 2)) = LCase(group) Then 'case-insensitive matching
            count = count + 1
            codes(count) = Data(i, 1)
        End If
    Next i
    
    If count > 0 Then
        ReDim Preserve codes(1 To count)
    End If
    
    getCodesByGroup = codes()
    
End Function

Before . . .

vbalad.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1		Code	Group		Results
2		1	D
3		2	B
4		3	B
5		4	A
6		5	C
7		6	C
8		7	B
9		8	C
10		9	D
11		10	B
12		11	A
13		12	D
14		13	C
15		14	B
16		15	D
17		16	B
18		17	A
19		18	B
20		19	A
Sheet1

After . . .

vbalad.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1		Code	Group		Results
2		1	D		D	1	9	12	15
3		2	B		B	2	3	7	10	14	16	18
4		3	B		A	4	11	17	19
5		4	A		C	5	6	8	13
6		5	C
7		6	C
8		7	B
9		8	C
10		9	D
11		10	B
12		11	A
13		12	D
14		13	C
15		14	B
16		15	D
17		16	B
18		17	A
19		18	B
20		19	A
Sheet1

Hope this helps!

 

[James006]

@Domenic
Thanks a lot !!! Works perfectly

Meanwhile, since I do not know how to filter 2D arrays, came up with the following ...

Could you kindly review and let me have your comments

Sub AB_Test()
'https://www.mrexcel.com/board/threads/vba-example-with-arrays
Dim arr As Variant, codes As Variant
Dim key As Variant, it As Variant
Dim i As Long, lcount As Long, ext As String

lcount = 1
With Sheet1
  arr = .Range("B2", .Range("C" & Rows.count).End(xlUp))
End With

    With CreateObject("Scripting.Dictionary")
        ' Create Dictionary
        For Each it In Application.index(arr, 0, 2)
            .Item(it) = it
        Next it
        ' Loop Dictionary to create Codes
        For Each key In .Keys
          ext = "": lcount = lcount + 1
            For i = 1 To UBound(arr)
                If arr(i, 2) = key Then
                    ext = ext & "_" & i
                    codes = Application.index(arr, Application.Transpose(Split(Mid(ext, 2), "_")), Array(1, 2))
                    'Display Final Results for Each Key
                    Cells(lcount, 6) = key
                    Cells(lcount, 7).Resize(, UBound(codes)) = Application.Transpose(codes)
                 End If
            Next i
        Next key
    End With
End Sub

 

[Domenic]

@Domenic
Thanks a lot !!! Works perfectly

You're very welcome, I'm glad I could help.

For your new question, though, please start a new thread.

Cheers!

 

[James006]

My comment has very little importance ....

The OP *vbalad is the person whose opinion really counts

 

[Domenic]

My comment has very little importance ....

Actually, your comments are important as well . . .

The OP *vbalad is the person whose opinion really counts

When you posted your code, was that meant for the OP? I thought it was a new question that you needed help with. Sorry if I misunderstood.

 

[James006]

Actually, your comments are important as well . . .

When you posted your code, was that meant for the OP? I thought it was a new question that you needed help with. Sorry if I misunderstood.

@ Domenic

My attempt was indeed posted for the OP ... but ALSO for your sharpened review

 

[Domenic]

@James006

Sorry again for my misunderstanding.

James, that's a very interesting approach. There's only one minor issue, though. It occurs when there's only one code for a group. Here's what I mean...

vbalad.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
1		Code	Group		Results
2		1	C		12	C	1	1
3		2	A			A	2	5	8
4		3	D			D	3	6	14	18
5		4	B			B	4	7	9	10	11	15	17	19
6		5	A			E	12	13	16
7		6	D
8		7	B
9		8	A
10		9	B
11		10	B
12		11	B
13		12	E
14		13	E
15		14	D
16		15	B
17		16	E
18		17	B
19		18	D
20		19	B
Sheet1

Cheers!

 

[James006]

@Domenic

Thanks a lot for your feedback AND for your insight ...

 

[vbalad]

Hi all,
Thank you very much for your help. I haven't had time to check yet because I had to take care of another task . I will come back with feedback.
Regards