Create a dynamic range based on the characteristic of the cells vba

Question

I want to compare the sum of two cells which are not in bold font or the color of interior of the cell is empty. I want to compare this sum of values of cells of the column that are together only when the label of the column is "miercoles", "jueves", "viernes" or "sabado" and just coloring the biggest result after consulting the four columns for the first labels 1, 2 , 3 and 4. I've made this code but I'm not saving any range in the variable g. How can I create the dynamic range g?

Sub reuniones_dos_horas()
    Dim r As Range
    Dim r2 As Range

    a = 2
    While Sheets("Dinamicos").Cells(27, a) <> ""
        b = 1
        While Sheets("Dinamicos").Cells(27, a) <= b + 3
            c = 2
            While Sheets("Dinamicos").Cells(29, c) <> ""
                Drev = Sheets("Dinamicos").Cells(29, c)
                If Sheets("Dinamicos").Cells(29, c) = "Miercoles" Or Sheets("Dinamicos").Cells(29, c) = "Jueves" Or Sheets("Dinamicos").Cells(29, c) = "Viernes " Or Sheets("Dinamicos").Cells(29, c) = "Sabado" Then
                    d = 30
                    While Sheets("Dinamicos").Cells(d + 1, c) <> ""
                        If Sheets("Dinamicos").Cells(d + 1, c).Interior.Pattern = xlNone And Sheets("Dinamicos").Cells(d, c).Interior.Pattern = xlNone And Sheets("Dinamicos").Cells(d + 1, c).Font.Bold = False And Sheets("Dinamicos").Cells(d, c).Font.Bold = False Then
                        e = Application.Sum(Sheets("Dinamicos").Cells(d + 1, c), Sheets("Dinamicos").Cells(d, c))
                        f = Application.Sum(Sheets("Dinamicos").Cells(d + 1, c), Sheets("Dinamicos").Cells(d + 2, c))
                        If e >= f Then
                            e_range1 = Sheets("Dinamicos").Range(Cells(d, c), Cells(d + 1, c)).Select
                        ElseIf f > e Then
                            f_range1 = Sheets("Dinamicos").Range(Cells(d + 1, c), Cells(d + 2, c)).Select
                        End If
                        For Each r2 In Range(Cells(30, c), Cells(44, c))
                            If r2.Font.Underline = True Then
                                If r Is Nothing Then
                                    Set r = Range(Cells(r2.Row, c))
                                Else
                                    Set r = Union(r, Range(Cells(r2.Row, c)))
                                End If
                            End If
                        Next

                        h = WorksheetFunction.Sum(ActiveRange)
                        g = WorksheetFunction.Sum(r)

                        If h >= g Then
                            Range(List).Activate
                            Range(List).Font.Underline = True
                        ElseIf g > h Then
                            ActiveRange.Select
                            ActiceRange.Font.Underline = True
                            Range(List).Font.Underline = False
                        End If

                        End If
                        d = d + 1
                    Wend
                End If
                c = c + 1
            Wend
            b = b + 1
        Wend
        a = a + 1
    Wend
End Sub

Andrea Santos Ruiz Andrea Santos Ruiz · Accepted Answer · 2017-06-09T16:44:02

If someone needs to do something similar, here is how i solve my problem

  Sub reuniones_dos_horas()


   Dim r As Range
   Dim r2 As Range
   Dim range1 As Range
   Dim ra As Range
   Dim W As Integer
   Dim W0 As Integer
   Dim ran As Range

   Sheets("Dinamicos").Range("B30:LG44").Font.Underline = False

    c = 2
    While Sheets("Dinamicos").Cells(29, c) <> ""
    Drev = Sheets("Dinamicos").Cells(29, c)
    If Sheets("Dinamicos").Cells(29, c) = "Miercoles" Or               
    Sheets("Dinamicos").Cells(29, c) = "Jueves" Or 
    Sheets("Dinamicos").Cells(29, c) = "Viernes " Or 
    Sheets("Dinamicos").Cells(29, c) = "Sabado" Then
    d = 30
        While Sheets("Dinamicos").Cells(d + 1, c) <> ""
            If Sheets("Dinamicos").Cells(d + 1, c).Interior.ColorIndex = xlNone And Sheets("Dinamicos").Cells(d, c).Interior.ColorIndex = xlNone And Sheets("Dinamicos").Cells(d + 1, c).Font.Bold = False And Sheets("Dinamicos").Cells(d, c).Font.Bold = False Then
            e = Application.Sum(Sheets("Dinamicos").Cells(d + 1, c), Sheets("Dinamicos").Cells(d, c))
            f = Application.Sum(Sheets("Dinamicos").Cells(d + 1, c), Sheets("Dinamicos").Cells(d + 2, c))
            If Sheets("Dinamicos").Cells(d, c).Interior.ColorIndex = xlNone And Sheets("Dinamicos").Cells(d + 1, c).Interior.ColorIndex = xlNone And Sheets("Dinamicos").Cells(d + 2, c).Interior.ColorIndex = xlNone Then
                If e >= f Then
                Set range1 = Union(Sheets("Dinamicos").Cells(d, c), Sheets("Dinamicos").Cells(d + 1, c))
                ElseIf f > e Then
                Set range1 = Union(Sheets("Dinamicos").Cells(d + 1, c), Sheets("Dinamicos").Cells(d + 2, c))
                End If
                For Each r2 In Range(Cells(30, c), Cells(44, c))
                    ver = r2.Row
                    ver2 = Cells(r2.Row, c)
                If r2.Interior.ColorIndex = xlNone Then
                    If r2.Font.Underline = xlUnderlineStyleSingle Then
                        If r Is Nothing Then
                        Set r = Cells(r2.Row, c)
                        Else
                        Set r = Union(r, Cells(r2.Row, c))

                        End If
                    End If
                End If
                Next

                g = WorksheetFunction.Sum(range1)
                If r Is Nothing Then
                h = g
                Else
                h = WorksheetFunction.Sum(r)
                End If


                If h >= g And r Is Nothing Then
                range1.Font.Underline = True
                Cells(47, c) = g
                ElseIf h >= g Then
                range1.Font.Underline = False
                r.Font.Underline = True
                Cells(47, c) = h
                ElseIf g > h Then
                r.Font.Underline = False
                range1.Font.Underline = True
                Cells(47, c) = g
                End If

                Set r = Nothing
            End If

            End If
        d = d + 1
        Wend
    End If
    c = c + 1
    Wend



   a1 = 1
   b1 = 2

   For a1 = 1 To 56 Step 4

   'While a1 <= 50
       While Sheets("Dinamicos").Cells(27, b1) < a1 + 3 And Sheets("Dinamicos").Cells(27, b1) <> ""
    If a1 > 50 Then
    Exit Sub
    Else
    W0 = Application.WorksheetFunction.CountIf(Range("B27:LG27"), "<" & a1)
    W = Application.WorksheetFunction.CountIf(Range("B27:LG27"), "<=" & a1 + 3)
    X = W - W0
    y = X - 23
    Y1 = y + 1
    Y2 = 1 + W - 23
    YY = Sheets("Dinamicos").Cells(47, 1 + W)
    XX = Sheets("Dinamicos").Cells(47, Y1)


Set ra = Range(Cells(47, Y2), Cells(47, 1 + W))
AddressOfMax(ra).Interior.Color = RGB(0, 102, 204)
col = AddressOfMax(ra).Column

    For Each rb In Range(Cells(30, col), Cells(44, col))
                    ver = rb.Row
                    ver2 = Cells(rb.Row, col)
                If rb.Font.Underline = xlUnderlineStyleSingle Then
                        If ran Is Nothing Then
                        Set ran = Cells(rb.Row, col)
                        Else
                        Set ran = Union(ran, Cells(rb.Row, col))
                        End If
                End If
    Next

    ran.Interior.Color = RGB(0, 102, 204)

     b1 = b1 + 1
       End If
       Wend
       b1 = 2
   Next a1
   'a1 = a1 + 4
   'Wend


   Call formato2

   End Sub

Create a dynamic range based on the characteristic of the cells vba

1 Answers