Renvoyer les données séquentielles au format conditionnel par le bouton

Question

Besoin de VBA pour renvoyer des ECRs> 30 jours avec le "Emplacement" dans lequel se trouvent les ECR. Lorsque vous cliquez sur le bouton facile. Le programme doit analyser les cellules rouges et créer un tableau et placer un tableau dans un autre classeur.

jusqu'à présent code:

Sub easy_button_2() 
Dim rw As Long, c As Long, fast As String, X 
fast = "Y" 

With Workbooks("ECR Log w_fast.xlsm").Sheets("Sheet 3") 

With Workbooks("ECR Log w_fast.xlsm").Sheets("Sheet 2") 

    'clear any previous ECR #s/Location results 
    rw = Application.Match("ECR #s", .Range(.Cells(3, 1), .Cells(Rows.Count, 1).End(xlUp)), 0) 
    With .Range(.Cells(rw + 24, 1), .Cells(Rows.Count, 1).End(xlUp)) 
     .Resize(.Rows.Count, 2).Offset(1, 0).ClearContents 
    End With 
    'reset the Locations named range 
    With .Range(.Cells(3, 1), .Cells(3, 1).End(xlDown)) 
     .Resize(.Rows.Count, .Cells(1, Columns.Count).End(xlToLeft).Column).Name = "Locations" 
    End With 

    'cycle through the ECRs in Locations' column 1 
    With .Range("Locations") 
     For rw = 2 To .Rows.Count 
      If .Cells(rw, 3) > 30 Or .Cells(rw, 2) = fast Then 
       For c = 3 To .Columns.Count 
        If .Cells(rw, c).DisplayFormat.Interior.Color = vbRed Then 
          .Parent.Cells(Rows.Count, 1).End(xlUp).Resize(1, 2).Offset(1, 0) = _ 
          Array(.Cells(rw, 1).Value2, .Cells(1, c).Value2) 
         Exit For 
        End If 
       Next c 
      End If 
     Next rw 
    End With 
End With 
End With 

'Workbooks.Open Nom du fichier: = "C: \ Users \ MJ \ Desktop \ ECR Monitor.xlsm" ' End Sub ThisWorkbook.Activate

Answer 1

Il existe deux manières différentes de déterminer l'état d'une règle de mise en forme conditionnelle directement à partir de la couleur de cellule observée. Vous pouvez utiliser le AutoFilter method comme vous avez commencé à faire ou utiliser le Range.DisplayFormat property pour vérifier le .Interior.ColorIndex (vous filtriez pour , pas).

^{Il semble que les emplacements gamme pourrait être étendue au-delà de la septième ligne. Pour le localiser dans une plage mise à jour dynamiquement, le nom défini Les emplacements seront redéfinis en fonction des cellules en expansion à partir de A3.}

Méthode 1: Méthode AutoFilter

Sub easy_button_1() 
    Dim rw As Long, c As Long, vr As Range 

    Application.ScreenUpdating = False 

    With Worksheets("sheet2") 
     If .AutoFilterMode Then .AutoFilterMode = False 

     'clear any previous ECR #s/Location results 
     rw = Application.Match("ECR #s", .Range(.Cells(4, 1), .Cells(Rows.Count, 1).End(xlUp)), 0) 
     With .Range(.Cells(rw + 3, 1), .Cells(Rows.Count, 1).End(xlUp)) 
      .Resize(.Rows.Count, 2).Offset(1, 0).ClearContents 
     End With 

     'reset the Locations named range 
     With .Range(.Cells(3, 1), .Cells(3, 1).End(xlDown)) 
      .Resize(.Rows.Count, .Cells(1, Columns.Count).End(xlToLeft).Column).Name = "Locations" 
     End With 

     'AutoFilter the Locations named range 
     With .Range("Locations") 
      .AutoFilter Field:=2, Criteria1:=">30" 
      For c = 3 To .Columns.Count 
       '.AutoFilter Field:=c, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterCellColor 
       .AutoFilter Field:=c, Criteria1:=vbRed, Operator:=xlFilterCellColor 
       If c > 3 Then 
        .AutoFilter Field:=c - 1, Criteria1:=vbGreen, Operator:=xlFilterCellColor 
        '.AutoFilter Field:=c - 1, Criteria1:=RGB(0, 255, 0), Operator:=xlFilterCellColor 
       End If 
       With .Resize(.Rows.Count - 1, 1).Offset(1, 0) 
        'only attempt to transfer values if there is something visible 
        If CBool(Application.Subtotal(103, .Cells)) Then 
         For Each vr In .SpecialCells(xlCellTypeVisible) 
         'cycle through the visible rows 
         .Parent.Cells(Rows.Count, 1).End(xlUp).Resize(1, 2).Offset(1, 0) = _ 
          Array(vr.Value2, .Cells(0, c).Value2) 
         Next vr 
        End If 
       End With 
       If c > 3 Then .AutoFilter Field:=c - 1 
       .AutoFilter Field:=c 
      Next c 
      .AutoFilter Field:=2 
     End With 

     If .AutoFilterMode Then .AutoFilterMode = False 
    End With 

    Application.ScreenUpdating = True 

End Sub 

étape par la procédure ci-dessus avec des robinets répétitif F8 pour regarder le processus de travail à travers.

Méthode 2: propriété Range.DisplayFormat

Sub easy_button_2() 
    Dim rw As Long, c As Long 

    With Worksheets("sheet2") 

     'clear any previous ECR #s/Location results 
     rw = Application.Match("ECR #s", .Range(.Cells(4, 1), .Cells(Rows.Count, 1).End(xlUp)), 0) 
     With .Range(.Cells(rw + 3, 1), .Cells(Rows.Count, 1).End(xlUp)) 
      .Resize(.Rows.Count, 2).Offset(1, 0).ClearContents 
     End With 

     'reset the Locations named range 
     With .Range(.Cells(3, 1), .Cells(3, 1).End(xlDown)) 
      .Resize(.Rows.Count, .Cells(1, Columns.Count).End(xlToLeft).Column).Name = "Locations" 
     End With 

     'cycle through the ECRs in Locations' column 1 
     With .Range("Locations") 
      For rw = 2 To .Rows.Count 
       If .Cells(rw, 2) > 30 Then 
        For c = 3 To .Columns.Count 
         If .Cells(rw, c).DisplayFormat.Interior.Color = vbRed Then 
          .Parent.Cells(Rows.Count, 1).End(xlUp).Resize(1, 2).Offset(1, 0) = _ 
           Array(.Cells(rw, 1).Value2, .Cells(1, c).Value2) 
          Exit For 
         End If 
        Next c 
       End If 
      Next rw 
     End With 

    End With 
End Sub 

étape la procédure ci-dessus avec des ponctions itératives F8 pour regarder le processus de travail à travers. Regardez les valeurs de rw et c changez comme vous faites défiler les Emplacements plage nommée.

^{Notez que les deux ci-dessus reposent sur des constantes de code couleur numérique de vbRed et vbGreen. Si vous utilisez des couleurs avec des nuances de RGB primaire (255, 0, 0) et RVB (0, 255, 0), vous devrez alors faire des ajustements.}

^{Filtrer par couleur}

Answer 2

si je voulais retourner les valeurs ce programme fonctionne sur une autre feuille de calcul ou un autre classeur? Puis-je simplement référencer le tableau dans un autre classeur? Peut-être déclarer le tableau comme une variable pour le référencer?

Ou dois-je placer le tableau dans une autre feuille de calcul et faire référence à un autre classeur?

Sub easy_button_2() 
Dim rw As Long, c As Long, fast As String 
fast = "Y" 
Dim ws3 As Worksheet 
Set ws3 = Workbooks("ECR Log w_fast.xlsm").Sheets("Sheet 3") 
With Workbooks("ECR Log w_fast.xlsm").Sheets("Sheet 2") 

    'clear any previous ECR #s/Location results 
    rw = Application.Match("ECR #s", .Range(.Cells(3, 1), .Cells(Rows.Count, 1).End(xlUp)), 0) 
    With .Range(.Cells(rw + 100, 1), .Cells(Rows.Count, 1).End(xlUp)) 
     .Resize(.Rows.Count, 2).Offset(1, 0).ClearContents 
    End With 
    'reset the Locations named range 
    With .Range(.Cells(3, 1), .Cells(3, 1).End(xlDown)) 
     .Resize(.Rows.Count, .Cells(1, Columns.Count).End(xlToLeft).Column).Name = "Locations" 
    End With 

    'cycle through the ECRs in Locations' column 1 
    With .Range("Locations") 
     For rw = 2 To .Rows.Count 
      If .Cells(rw, 3) > 30 Or .Cells(rw, 2) = fast Then 
       For c = 3 To .Columns.Count 
        If .Cells(rw, c).DisplayFormat.Interior.Color = vbRed Then 
          ws3.Cells(Rows.Count, 1).End(xlUp).Resize(1, 2).Offset(1, 0) = _ 
          Array(.Cells(rw, 1).Value2, .Cells(1, c).Value2) 
         Exit For 
        End If 
       Next c 
      End If 
     Next rw 
    End With 
End With 

End Sub