Tekrarlanan Değerlere Dayalı Renk Satırları - excel vba

Question

Ekibimin seyahat planları için her hafta aldığım bir excel dosyasını basitleştirmeye çalışıyorum.

Ekip üyenin adı, uçuş numarası # ve varış zamanı.

Takım üyelerim bazen farklı uçuşlara katılıyor. Hangi saatte varacağımı görsel olarak görmek isterim ki bu sayede kiralık araç düzenlemelerini kolayca yapabilirim. Eğer bir grup 1:06'ya ulaşırsa, ben onları bir diğeriyle 6:55 de vurgulayacağım - bunları vurgulayacağım. 15 farklı uçuş planımız olabilir. Şu anda ortak olanları tanımlamak için koşullu biçimlendirme kullanıyorum, ancak her hafta bunu 50 kişi için yaptığımdan, çalıştırmak için bir vba modülüne geçmek uygun olacaktır. (Zaten bazı sütunları/satırları yeniden biçimlendiren bir modülüm var).

Yinelenen kod tanımlayıcılarına ve bu ana kaynakım Compare Dates/Times'a baktım, ancak şimdiye kadar hiç şans olmadı. Şimdi ne yaptığım ait

Resim: highlight

Answer 1

Ben kodlanmış olan yönlü veri bir tabloya biçimlendirilir olmasıdır, daha sonra 'Uçuş #' sütununda benzersiz değerler hesaplanır. Veriler daha sonra bu değerler ile sırayla süzüldü ve sıralar önceden belirlenmiş bir paletten (değiştirilebilen) renklendirildi. ******

Sub FormatDuplicateRows() 

    Dim wsFlight As Worksheet: Set wsFlight = Worksheets("Flights") 

    On Error Resume Next 
    If Not wsFlight.ListObjects("Flights") Is Nothing Then wsFlight.ListObjects("Flights").Unlist 
    On Error GoTo 0 

    wsFlight.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = "Flights" 
    Dim tblFlight As ListObject: Set tblFlight = wsFlight.ListObjects("Flights") 

    Dim Fld As Long: Fld = tblFlight.ListColumns("Flight #").Range.Column 

    Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary") 
    For Each Cell In tblFlight.ListColumns("Flight #").DataBodyRange 
     If Not Dict.Exists(Cell.Value) Then Dict.Add Cell.Value, Cell.Address 
    Next 

    Dim Colours() As String: Colours = Split("&HD9E9FD,&HF3EEDB,&HECE0E5,&HDDF1EA,&HDCDDF2,&HCCFFFF", ",") 
    Dim i As Long: i = 0 
    With tblFlight 
     .TableStyle = "TableStyleLight1" 
     .ShowTableStyleRowStripes = False 
     For Each Value In Dict.Keys 
      .Range.AutoFilter Field:=Fld, Criteria1:=Value 
      .DataBodyRange.SpecialCells(xlCellTypeVisible).Interior.Color = Colours(i) 
      i = IIf(i = UBound(Colours), 0, i + 1) 
     Next Value 
     .Range.AutoFilter Field:=Fld 
    End With 

End Sub 

Sen ihtiyaçlarına paleti değiştirebilir ve palet otomatik tekrar bir kez tüm renkler

********* GÜNCELLEME kez kullanılmış olacak ****

dizi için renk değerlerini elde etmek için bir Şimdi aşağıdaki

Public Function GetColour(rngSrc As Range) As String 
    GetColour = "&H" & Application.WorksheetFunction.Dec2Hex(rngSrc.Interior.Color) 
End Function 

kodlanmış bir excel çalışma kitabında, sadece "A2" ve formül = GetColour ("A1") yerleştirilir ve dolgu rengini o değiştirdi satır 1 boyunca bazı hücreleri f sonra formülü sürükle-bıraktı formülü dize değerleri almak için formül bıraktı