Categorizing group of numbers which depicts an area coverage on a grid map

[Chlwls808]

Hi,

I think this is more of a VBA question than a function.

Imagine a grid system that is numbered based on rows and columns. The numbers are rows, and letters are column - sort of like an excel sheet except rows increase from bottom to top.

4A 4B 4C 4D
3A 3B 3C 3D
2A 2B 2C 2D
1A 1B 1C 1D

Now, imagine again that each grid has 9 boxes numbered from top to bottom - 3 numbers per row (something like your telephone keypad).

The following list are coordinates which covers the grid. The numbers following the letter represent the area of each grid it covers (keypad format).

4A89
4B789
4C78
3A2356
3B123456
3C1245
2C9
2D78
1C3
1D12

If the list were randomized, is there a programmatical way to distinguish the list and categorize them by their areas? Whether if it's in two separate columns or text, doesn't matter; As long as they are separated.

 

[Chlwls808]

I assume that the above quotes relate to the same thing?
Can you explain and give examples, including location, of what 20-8 or 90, 91, 92, 93, 94, 95, 96, 97, 98 actually means?

The first group in the coordinates are the numbers which corresponds to each 3x3 grid on the vertical axis. And the letters corresponds to horizontal range. They represent certain area that the coordinates point to. The numbers I'm dealing with usually fit within the 90's range so I'm OK with bottom row being 90 and the top as 98. I imagined changing the hardcoded numbers in the code if I needed to represent the map to be in a range that's something else, like 20's for example. I don't know what the implications are to the Excel performance if I tried making a grid much larger than that to accommodate beyond just the 90's range so I didn't put it out there.

Example could be:
94AA235689
94AB123456789
94AC1245789
93AC123
93AD123456
93AE14578
97AF2356
97AG1245678
98AG124578

PS: One thing to note is that my whole intention was to devise a way to segregate a group of numbers like above that are in its own area (borders not touching) and not the map itself.

It certainly is not happening for me.

• Select a single cell somewhere on the sheet
• Ctrl+F to bring up the Find dialog
• Find what: leave blank, make sure Options>> is expanded, click the down arrow beside Format..., if 'Clear Find Format is not greyed out then click it & then the down arrow again and choose Format..., put a tick beside merge cells, View attachment 46626, OK, Find All
• If the sheet has merged cells you should see something like this that identifies where they are View attachment 46627

Good to know!

 

[tonyyy]

Creating a "map" with vertical blocks numbered from 90 to 98...

MapGrid 210903.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X
1																			1	2
2																			4	5
3																			7	8
4																	2	3	1	2
5																	5	6	4	5	6
6																			7	8
7
8
9
10
11
12
13		2	3	1	2	3	1	2
14		5	6	4	5	6	4	5
15		8	9	7	8	9	7	8	9
16							1	2	3	1	2	3	1
17										4	5	6	4	5
18													7	8
19
20
21
Map

MapGrid 210903.xlsm
	A	B	C
1	94AA235689	98AG124578	94AA235689
2	94AB123456789	97AF2356	94AB123456789
3	94AC1245789	97AG1245678	94AC1245789
4	93AC123		93AC123
5	93AD123456		93AD123456
6	93AE14578		93AE14578
7	97AF2356
8	97AG1245678
9	98AG124578
List

Sub FillMap2()
Dim nm As Name
Dim r1 As Range, r2 As Range
Dim i As Long, j As Long
Dim sht1 As String, sht2 As String

Application.ScreenUpdating = False
sht1 = "List"
sht2 = "Map"
For Each r1 In Sheets(sht1).Range("A1:A" & Sheets(sht1).Cells(Rows.Count, "A").End(xlUp).Row)
    For Each nm In ActiveWorkbook.Names
        If nm.RefersToRange.Parent.Name = Sheets(sht2).Name Then
            For j = 1 To Len(r1.Text)
                If Not (IsNumeric(Mid(r1.Text, j, 1))) Then Exit For
            Next j
            If Left(r1.Value, j + 1) = Mid(nm.Name, 2, j + 1) Then
                Set r2 = Range(nm).Cells(1, 1)
                i = 2
                Do Until i = Len(r1)
                    i = i + 1
                    If Mid((r1), i, 1) = 1 Then r2.Offset(0, 0) = 1
                    If Mid((r1), i, 1) = 2 Then r2.Offset(0, 1) = 2
                    If Mid((r1), i, 1) = 3 Then r2.Offset(0, 2) = 3
                    If Mid((r1), i, 1) = 4 Then r2.Offset(1, 0) = 4
                    If Mid((r1), i, 1) = 5 Then r2.Offset(1, 1) = 5
                    If Mid((r1), i, 1) = 6 Then r2.Offset(1, 2) = 6
                    If Mid((r1), i, 1) = 7 Then r2.Offset(2, 0) = 7
                    If Mid((r1), i, 1) = 8 Then r2.Offset(2, 1) = 8
                    If Mid((r1), i, 1) = 9 Then r2.Offset(2, 2) = 9
                Loop
            End If
        End If
    Next nm
Next r1
Application.ScreenUpdating = True
End Sub

Sub MapGroup()
Dim Group As Range, rng As Range
Dim str2 As String, str3 As String
Dim nm As Name
Dim LastRow As Long, LastCol As Long
Dim sht1 As String, sht2 As String

Application.ScreenUpdating = False
Set Group = Selection
sht1 = "List"
sht2 = "Map"
LastCol = Sheets(sht1).Cells(1, Columns.Count).End(xlToLeft).Column

''' Loop thru named ranges
For Each nm In ActiveWorkbook.Names
    str2 = ""
    If Not Intersect(Range(nm.Name), Group) Is Nothing Then
        For Each rng In Range(nm.Name)
            If Not Intersect(Range(nm.Name), rng) Is Nothing And rng <> "" Then
                str2 = str2 & rng.Value
            End If
        Next rng
        If str2 <> "" Then
            str3 = Right(nm.Name, Len(nm.Name) - 1) & str2
            LastRow = Sheets(sht1).Cells(Rows.Count, LastCol + 1).End(xlUp).Row
            If Sheets(sht1).Cells(LastRow, LastCol + 1) = "" Then
                Sheets(sht1).Cells(LastRow, LastCol + 1) = str3
            Else
                Sheets(sht1).Cells(LastRow + 1, LastCol + 1) = str3
            End If
        End If
    End If
Next nm

Sheets(sht1).Activate
Dim r1 As Range, j As Long
''' Separate alphanumeric characters into helper columns
For Each r1 In Sheets("List").Range(Cells(1, LastCol + 1), Cells(LastRow + 1, LastCol + 1))
    For j = 1 To Len(r1.Text)
        If Not (IsNumeric(Mid(r1.Text, j, 1))) Then
            r1.Offset(0, 1) = Mid(r1.Text, 1, j - 1)
            r1.Offset(0, 2) = Mid(r1.Text, j, 2)
            r1.Offset(0, 3) = Mid(r1.Text, j + 2, Len(r1.Text) - j - 1)
            Exit For
        End If
    Next j
Next r1
''' Sort the list
Sheets("List").Range(Cells(1, LastCol + 1), Cells(LastRow + 1, LastCol + 3)).Offset(0, 1).Sort _
    key1:=Cells(1, LastCol + 2), order1:=xlDescending, _
    key2:=Cells(1, LastCol + 3), order2:=xlAscending, Header:=xlNo
Sheets("List").Range(Cells(1, LastCol + 1), Cells(LastRow + 1, LastCol + 1)).Offset(0, 4).FormulaR1C1 = "=CONCATENATE(RC[-3],RC[-2],RC[-1])"
Sheets("List").Range(Cells(1, LastCol + 1), Cells(LastRow + 1, LastCol + 1)).Offset(0, 4).Value = Sheets("List").Range(Cells(1, LastCol + 1), Cells(LastRow + 1, LastCol + 1)).Offset(0, 4).Value
Sheets("List").Range(Cells(1, LastCol + 1), Cells(LastRow + 1, LastCol + 1)).Value = Sheets("List").Range(Cells(1, LastCol + 1), Cells(LastRow + 1, LastCol + 1)).Offset(0, 4).Value
Sheets("List").Range(Cells(1, LastCol + 1), Cells(LastRow + 1, LastCol + 1)).Resize(, 4).Offset(0, 1).Delete
Application.ScreenUpdating = True

End Sub

The code has been revised to accommodate 1 or 2 digit prefixes.

Curious... how do you solve this now? Do you reference a map?

 

[Chlwls808]

The code has been revised to accommodate 1 or 2 digit prefixes.

Curious... how do you solve this now? Do you reference a map?

Hey @tonyyy , Thanks for the update. I got a fresh sheet and executed the FillMap2 but nothing happens in the Map sheet. Do I need to name the ranges accordingly first?

 

[Chlwls808]

Hey @tonyyy , Thanks for the update. I got a fresh sheet and executed the FillMap2 but nothing happens in the Map sheet. Do I need to name the ranges accordingly first?

@tonyyy disregard. That was it!

Curious... how do you solve this now? Do you reference a map?

There's nothing to solve. I'm able to separate the list by its areas which was what I was looking for. The coordinates are already referenced to a given area; there needed to be a way to isolate them somehow.

Thanks a bunch! I'm still baffled how generous you guys are here. I really hope this thread helps out someone else in the future!

 

[Chlwls808]

@tonyyy I'm not sure if you ever come across this issue but I when I copy a worksheet from another workbook and put it alongside List and Map, I notice this error pops out at me each time I execute FillMap2 again. I also tried adding a new worksheet to an existing workbook that I already use and named it List and Map, and they produce the same issue. The only time when I can get this work without any error is when I build from scratch a complete new worksheet by itself.

Runtime error 1004: Application or object-defined error.

Debug:

I looked up some sources on the possible causes and they mention the following.. but I'm not sure if any of the FillMap2 code pertains to them or not.

• 1 VBA code refers to a range that doesn’t exist
• 2 You are trying to enter a value that is not a range
• 3 Select a worksheet explicitly
• 4 You are using protected mode
• 5 Macro recorded at the worksheet level

VBA Runtime Error 1004 “Application-defined or Object-defined error”

Troubleshoot and resolve the VBA Runtime Error 1004, "Application-defined or Object-defined error," in this guide. From referencing non-existent ranges to handling protected worksheets.

excel.officetuts.net

 

[Chlwls808]

@tonyyy I may have figured it out. Please disregard above comment for now.
Thanks!

 

[Peter_SSs]

I imagined changing the hardcoded numbers in the code if I needed to represent the map to be in a range that's something else, like 20's for example.

OK, given that, here is my attempt (not greatly tested) for filling and mapping without named ranges.
Still assuming that we can have a blank row 1 and column A (hidden if you want)
Also assuming column CB is blank

Sub FillAndMapLarge_v2()
  Dim d As Object, dGr As Object
  Dim itms As Variant
  Dim r As Range, c As Range
  Dim i As Long, j As Long, k As Long, Grp As Long, fr As Long, NumDigits As Long
  Dim adr As String, pref As String
  
  Const RowRange As String = "90-98" '<- Set your prefix row range here
  
  fr = Split(RowRange, "-")(0)
  
  'Fill
  Application.ScreenUpdating = False
  Range("B2:CA28").ClearContents
  NumDigits = Len(CStr(fr))
  For Each r In Range("CC2", Range("CC" & Rows.Count).End(xlUp))
    With Cells(29 - 3 * (Left(r.Value, NumDigits) - fr + 1), 3 * (Asc(Mid(r.Value, NumDigits + 2, 1)) - 64) - 1).Resize(3, 3)
      For i = NumDigits + 3 To Len(r.Value)
        .Cells(Mid(r.Value, i, 1)) = Mid(r.Value, i, 1)
      Next i
    End With
  Next r
  
  'Map
  Set d = CreateObject("Scripting.Dictionary")
  Set dGr = CreateObject("Scripting.Dictionary")
  
  For i = 2 To 28
    For j = 2 To 79
      If Not IsEmpty(Cells(i, j).Value) Then
        Set c = Cells(i, j)
        adr = c.Address(0, 0)
        pref = (fr + 8 - Int((c.Row - 2) / 3)) & "A" & Chr(Int((c.Column - 2) / 3) + 65) & "*"
        If d.exists(c.Offset(, -1).Address(0, 0)) Then
          d(adr) = d(c.Offset(, -1).Address(0, 0))
        Else
          k = 0
          Do Until IsEmpty(c.Offset(, k).Value)
            If d.exists(c.Offset(-1, k).Address(0, 0)) Then
              d(adr) = d(c.Offset(-1, k).Address(0, 0))
              Exit Do
            End If
            k = k + 1
          Loop
        End If
        If Not d.exists(adr) Then
          Grp = Grp + 1
          d(adr) = "Group " & Grp
        End If
        
        'Check column CC values & allocate to group
        For Each r In Range("CC1", Range("CC" & Rows.Count).End(xlUp))
          If r.Value Like pref & c.Value & "*" Then
            dGr(d(adr)) = dGr(d(adr)) & " " & r.Value
            Exit For
          End If
        Next r
      End If
    Next j
  Next i

  'Check column CC values & allocate to group
  For Each r In Range("CC1", Range("CC" & Rows.Count).End(xlUp))
    If r.Value Like pref & c.Value & "*" Then
      dGr(d(adr)) = dGr(d(adr)) & " " & r.Value
      Exit For
    End If
  Next r
  
  'Enter results in columns CE onwards
  Range("CE2").CurrentRegion.ClearContents
  For Grp = 1 To dGr.Count
    Range("CD2").Offset(, Grp).Value = dGr.Keys()(Grp - 1)
    itms = Split(Mid(dGr.Items()(Grp - 1), 2))
    With Range("CD2").Offset(1, Grp).Resize(UBound(itms) + 1)
      .Value = Application.Transpose(itms)
      .Resize(.Rows.Count + 1).RemoveDuplicates Columns:=1, Header:=xlNo
    End With
  Next Grp
  Application.ScreenUpdating = True
End Sub

Results using your sample values from post #31

Chlwls808_tonyyy.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB																																																	BY	BZ	CA	CB	CC	CD	CE	CF
1
2																				1	2																																																												94AA235689		Group 1	Group 2
3																				4	5																																																												94AB123456789		98AG124578	94AA235689
4																				7	8																																																												94AC1245789		97AF2356	94AB123456789
5																		2	3	1	2																																																												93AC123		97AG1245678	94AC1245789
6																		5	6	4	5	6																																																											93AD123456			93AC123
7																				7	8																																																												93AE14578			93AD123456
8																																																																																	97AF2356			93AE14578
9																																																																																	97AG1245678
10																																																																																	98AG124578
11
12
13
14			2	3	1	2	3	1	2
15			5	6	4	5	6	4	5
16			8	9	7	8	9	7	8	9
17								1	2	3	1	2	3	1
18											4	5	6	4	5
19														7	8
20
21
22
23
24
25
26
27
28
Large (2)

And a couple of other examples with RowRange set to "1-9"

Chlwls808_tonyyy.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M																																																																			CB	CC	CD	CE	CF
1
2																																																																																	9AA89		Group 1	Group 2
3																																																																																	9AB789		9AA89	7AC1256
4			8	9	7	8	9																																																																										6AD1		9AB789	7AD47
5							3																																																																										6AC23		8AB369	6AC23
6							6																																																																										8AB369			6AD1
7							9																																																																										7AC1256
8								1	2																																																																								7AD47
9									5	6	4
10											7
11									2	3	1
12
13
Large (3)

Chlwls808_tonyyy.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M																																																																			CB	CC	CD	CE	CF
1
2																																																																																	9AA89		Group 1
3																																																																																	9AB789		9AA89
4			8	9	7	8	9																																																																										6AD1		9AB789
5							3																																																																										6AC23		8AB369
6							6																																																																										8AB369		8AC7
7							9	7																																																																									7AC1256		7AC1256
8								1	2																																																																								7AD47		7AD47
9									5	6	4																																																																						8AC7		6AC23
10											7																																																																								6AD1
11									2	3	1
12
13
Large (3)

 

[Chlwls808]

@Peter_SSs Wow, caps off to you. This works perfectly.

So far all the data I've used has passed!

Thank you so much.

 

[Peter_SSs]

You're welcome. Glad it works for you. Thanks for the confirmation.