modificar codigo para que se ejecute en otra columna

[dragonfire33]

Sub colorearnumeros_5()
  'Por Dante Amor
"La idea es que se ejecute a partir de la columna F hasta la columna AV"
  Dim a As Variant, b As Variant, ky As Variant
  Dim i As Long, j As Long, k As Long, lr As Long, w As Long
  Dim m As Long, n As Long, x As Long, y As Long, cTot As Long
  Dim cad As String, coordenada As String
  Dim dic1 As Object, dic2 As Object
  Dim rng As Range, rngAma As Range, rngRoj As Range
  '
  lr = Range("F:AV").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row + 1
  Set rng = Range("F1:AV" & lr)
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  Set rngAma = Cells(1, 3)
  Set rngRoj = Cells(1, 3)
  rng.Interior.Color = xlNone
  a = rng.Value
  cTot = Int(rng.Columns.Count / 5) + 1
  '
  ReDim b(1 To UBound(a, 1) * cTot, 1 To UBound(a, 1) * cTot)
  '
  'Almacena en un diccionario todos los números de tres en tres
  For j = 1 To UBound(a, 2) Step 8
    For i = 2 To UBound(a, 1) - 1 Step 2
      'Revisar celdas mayor a 10
      If a(i + 1, j + 0) > 10 Then Set rngRoj = Union(rngRoj, Cells(i + 1, j + 2 + 0))
      If a(i + 1, j + 1) > 10 Then Set rngRoj = Union(rngRoj, Cells(i + 1, j + 2 + 1))
      If a(i + 1, j + 2) > 10 Then Set rngRoj = Union(rngRoj, Cells(i + 1, j + 2 + 2))
      '
      If a(i, j) <> "" Then
        For w = 1 To 6
          'combinaciones de 3 números
          Select Case w
            Case 1: cad = a(i, j + 0) & "|" & a(i, j + 1) & "|" & a(i, j + 2)
            Case 2: cad = a(i, j + 0) & "|" & a(i, j + 2) & "|" & a(i, j + 1)
            Case 3: cad = a(i, j + 1) & "|" & a(i, j + 0) & "|" & a(i, j + 2)
            Case 4: cad = a(i, j + 1) & "|" & a(i, j + 2) & "|" & a(i, j + 0)
            Case 5: cad = a(i, j + 2) & "|" & a(i, j + 0) & "|" & a(i, j + 1)
            Case 6: cad = a(i, j + 2) & "|" & a(i, j + 1) & "|" & a(i, j + 0)
          End Select
          '
          coordenada = i & "|" & j
          If Not dic1.exists(cad) Then
            y = y + 1
            dic1(cad) = 1 & "|" & y & "|" & 1
            dic2(coordenada) = Empty
          Else
            If Not dic2.exists(coordenada) Then
              x = Split(dic1(cad), "|")(0)
              n = Split(dic1(cad), "|")(1)
              m = Split(dic1(cad), "|")(2)
              x = x + 1
              dic1(cad) = x & "|" & n & "|" & m
            End If
          End If
          x = Split(dic1(cad), "|")(0)
          n = Split(dic1(cad), "|")(1)
          m = Split(dic1(cad), "|")(2)
          'Alamcena en la matriz 'b' todas las coordenas (fila, columna) de los números
          b(n, m) = coordenada
          m = m + 1
          dic1(cad) = x & "|" & n & "|" & m
        Next
      End If
    Next
  Next
  '
  'Revisa cuáles números (de 3) tienen duplicados
  For Each ky In dic1.keys
    x = Split(dic1(ky), "|")(0)
    If x > 1 Then
      'si tiene duplicado, obtiene los datos del diccionario
      n = Split(dic1(ky), "|")(1)
      m = Split(dic1(ky), "|")(2) - 1
      For k = 1 To m
        'obtiene las coordenas de la matriz 'b' de las celdas a colorear
        coordenada = b(n, k)
        i = Split(coordenada, "|")(0)
        j = Split(coordenada, "|")(1) + 2
        Set rngAma = Union(rngAma, Cells(i, j).Resize(1, 3))
      Next
    End If
  Next
  'colorea las celdas
  rngAma.Interior.Color = vbYellow
  rngRoj.Interior.Color = vbRed
  Cells(1, 3).Interior.Color = xlNone
End Sub

 

[DanteAmor]

Actualiza estas líneas:

      If a(i + 1, j + 0) > 10 Then Set rngRoj = Union(rngRoj, Cells(i + 1, j + 5 + 0))
      If a(i + 1, j + 1) > 10 Then Set rngRoj = Union(rngRoj, Cells(i + 1, j + 5 + 1))
      If a(i + 1, j + 2) > 10 Then Set rngRoj = Union(rngRoj, Cells(i + 1, j + 5 + 2))

        j = Split(coordenada, "|")(1) + 5

Prueba y me comentas.

 

[dragonfire33]

Gracias Dante funciona