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.

 

[tonyyy]

Hey there,
So this is how I imagined your description...
Before:

After:

Sub Matchh()
Dim r1 As Range, r2 As Range
Columns("F:F").TextToColumns Destination:=Range("F1"), DataType:=xlFixedWidth, _
    FieldInfo:=Array(Array(0, 1), Array(2, 1)), TrailingMinusNumbers:=True
For Each r1 In Range("F1:F" & Cells(Rows.Count, "F").End(xlUp).Row)
    For Each r2 In Range("A1:D13")
        If r1 = r2 Then
            If r2.Offset(1, 0) = "" Then
                r2.Offset(1, 0) = r1.Offset(0, 1)
            ElseIf r2.Offset(2, 0) = "" Then
                r2.Offset(2, 0) = r1.Offset(0, 1)
            Else
                r2.Offset(3, 0) = r1.Offset(0, 1)
            End If
        End If
    Next r2
Next r1
End Sub

In this implementation, the grid is in Range("A1:D13") and the randomized list is in Column F.

The code utilizes the TextToColumns function to separate the coordinates, then compares each category to the grid to place the data.

Hope this helps. Cheers,

tony

 

[Chlwls808]

Wow, although this is not what I had in mind, I'm really impressed with what you did here. Never would I have imagined such a thing was possible! I'll keep this code and think about what I can do with it.

As to what I was really going for, I wanted to split the list in two different groups if they are not in one space. Meaning, if I had a random list like this:

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

It will be able to separate into two groups based on the connecting borders on each grid.

Group 1:
4A89
4B789
4C78
3A2356
3B123456
3C1245

Group 2:
2C9
2D78
1C3
1D12

After I posted my first question, I was almost sure I will get no response.. but now I'm slightly hopeful

Thank you. Even if you don't come up with anything, I will mark your answer as solution!

 

[tonyyy]

Well I think I have a better understanding of what you're trying to accomplish. The following presents one possible solution, albeit it's not totally programmatic; you do have to intervene and select a group of cells.

Before:

After:

Each of the colored blocks is a Named Range:

Named Ranges

\1A =Map!$A$10:$C$12

\1B =Map!$D$10:$F$12

\1C =Map!$G$10:$I$12

\1D =Map!$J$10:$L$12

\2A =Map!$A$7:$C$9

\2B =Map!$D$7:$F$9

\2C =Map!$G$7:$I$9

\2D =Map!$J$7:$L$9

\3A =Map!$A$4:$C$6

\3B =Map!$D$4:$F$6

\3C =Map!$G$4:$I$6

\3D =Map!$J$4:$L$6

\4A =Map!$A$1:$C$3

\4B =Map!$D$1:$F$3

\4C =Map!$G$1:$I$3

\4D =Map!$J$1:$L$3

This first macro, FillMap, populates the grid with the list in Column N:

Sub FillMap()
Dim r1 As Range, r2 As Range
Dim i As Long

Columns("N:N").Sort key1:=Range("N1"), order1:=xlDescending, Header:=xlNo
For Each r1 In Range("N1:N" & Cells(Rows.Count, "N").End(xlUp).Row)
    If Left(r1.Value, 2) = "4A" Then Set r2 = Range("A1")
    If Left(r1.Value, 2) = "4B" Then Set r2 = Range("D1")
    If Left(r1.Value, 2) = "4C" Then Set r2 = Range("G1")
    If Left(r1.Value, 2) = "4D" Then Set r2 = Range("J1")
    If Left(r1.Value, 2) = "3A" Then Set r2 = Range("A4")
    If Left(r1.Value, 2) = "3B" Then Set r2 = Range("D4")
    If Left(r1.Value, 2) = "3C" Then Set r2 = Range("G4")
    If Left(r1.Value, 2) = "3D" Then Set r2 = Range("J4")
    If Left(r1.Value, 2) = "2A" Then Set r2 = Range("A7")
    If Left(r1.Value, 2) = "2B" Then Set r2 = Range("D7")
    If Left(r1.Value, 2) = "2C" Then Set r2 = Range("G7")
    If Left(r1.Value, 2) = "2D" Then Set r2 = Range("J7")
    If Left(r1.Value, 2) = "1A" Then Set r2 = Range("A10")
    If Left(r1.Value, 2) = "1B" Then Set r2 = Range("D10")
    If Left(r1.Value, 2) = "1C" Then Set r2 = Range("G10")
    If Left(r1.Value, 2) = "1D" Then Set r2 = Range("J10")

    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
Next r1
End Sub

At that point it'll be easy to see the contiguous groups. Select the first group and run the code below; then select the second group and run the code.

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

Application.ScreenUpdating = False
Set Group = Selection
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column

''' Loop thru named ranges
For Each nm In ActiveWorkbook.Names
    str2 = ""
    ''' Specify  named ranges on the active sheet only
    If nm.RefersToRange.Parent.Name = ActiveSheet.Name Then
        ''' If a cell in the Selection is within a named range then add the cell value to a list
        For Each rng In Group
            If Not Intersect(Range(nm.Name), rng) Is Nothing Then
                str2 = str2 & rng.Value
            End If
        Next rng
        ''' Add the range name to the list and write the list to the worksheet
        If str2 <> "" Then
            str3 = Right(nm.Name, 2) & str2
            LastRow = Cells(Rows.Count, LastCol + 1).End(xlUp).Row
            If Cells(LastRow, LastCol + 1) = "" Then
                Cells(LastRow, LastCol + 1) = str3
            Else
                Cells(LastRow + 1, LastCol + 1) = str3
            End If
        End If
    End If
Next nm

''' Sort the list
Range(ActiveSheet.Cells(1, LastCol + 1), ActiveSheet.Cells(LastRow + 1, LastCol + 1)).Select
Selection.TextToColumns Destination:=ActiveSheet.Cells(1, LastCol + 1), DataType:=xlFixedWidth, _
    FieldInfo:=Array(Array(0, 1), Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
ActiveSheet.Range(Cells(1, LastCol + 1), Cells(LastRow + 1, LastCol + 3)).Sort key1:=Cells(1, LastCol + 1), _
    key2:=Cells(1, LastCol + 2), order1:=xlDescending, order2:=xlAscending, Header:=xlNo
Selection.Offset(0, 3).FormulaR1C1 = "=CONCATENATE(RC[-3],RC[-2],RC[-1])"
Selection.Offset(0, 3).Value = Selection.Offset(0, 3).Value
Selection = Selection.Offset(0, 3).Value
Selection.Resize(, 3).Offset(0, 1).Delete

Application.ScreenUpdating = True
End Sub

There may be a way to programmatically find contiguous groups of cells but that's beyond my capability at the moment.

Good luck!

 

[Chlwls808]

@tonyyy wow, this is so cool! I got it to work in filling the map, but I'm not sure what you mean by selecting the first group. Do you mean to select the range of cells of first group in the map and run the macro? If so, I get a Run-time error. Any idea what I'm doing wrong?

 

[tonyyy]

"... I'm not sure what you mean by selecting the first group. Do you mean to select the range of cells of first group in the map and run the macro? If so, I get a Run-time error. Any idea what I'm doing wrong?"
1. Yes, select the first range of cells and run the macro.
2. Did you add the Named Ranges to the sheet? The names should be as indicated... \1A, \!B, \1C, etc.

 

[Chlwls808]

"... I'm not sure what you mean by selecting the first group. Do you mean to select the range of cells of first group in the map and run the macro? If so, I get a Run-time error. Any idea what I'm doing wrong?"
1. Yes, select the first range of cells and run the macro.
2. Did you add the Named Ranges to the sheet? The names should be as indicated... \1A, \!B, \1C, etc.

Yes, I did. I'll try to reinsert the module and see if that helps.

 

[Chlwls808]

Tony, actually, the group appears next to the N column after running the macro, despite getting the debut error. Also noticed it doesn't sort the same way as yours.

 

[tonyyy]

What's the message in the run time error?
(I'm surprised it actually ran, given the error.)
And are there other named ranges on the sheet?

 

[Chlwls808]

What's the message in the run time error?
I'm surprised it actually ran, given the error.

It's the following error:
It runs it after hitting End or Debug