セルの特性に基づいてダイナミックレンジを作成する

Question

太字ではない2つのセルの合計を比較するか、セルの内部の色が空です。私は、列のラベルが "miercoles"、 "jueves"、 "viernes"、 "sabado"の場合にのみ一緒になっている列のセルの合計値を比較し、4つの列を参照した後に最大の結果を得ます 私はこのコードを作ったが、変数gに範囲を保存していません。 どのようにしてダイナミックレンジ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 

Answer 1

誰かがここでは、類似した何かをする必要がある場合は、私は私の問題を解決する方法である

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