Új hozzászólás Aktív témák

• #45390 KBaj csendes tag Fferi50 #45384

  Új Válasz 2020-11-20 18:38:13 #45390

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  KBaj

  csendes tag

  válasz Fferi50 #45384 üzenetére

  Kedves Fferi50 !
  Mint ahogy írtam is a legutóbbi bejegyzésemben, dolgozom az ügyön és most félállásban vagyok, de igen jók a kilátások, hála Neked. A saját számíze szerint átírtam a kódot, úgy néz ki szépen működik és gyors!!! Íme a példa:
  '***** Prohardver nyomám Színes cellák számolása
  Sub CountCcolor() 'Cellaszín szerinti darabszám
  Dim cel As Range, cminta As Range, cter As Range, countcl As Long
  Dim xcolor As Long
  Dim j As Integer
  Range("O14:S14").ClearContents 'Színtalálatok törlése
  'If Selection.Areas.Count <> 2 Then MsgBox "Nem megfelelő a terület kijelölése", vbCritical: Exit Sub
  ' If Selection.Areas(1).Cells.Count = 1 Then ' Kijelölt területek azonostása: Count=1 Mintaszín
  ' Set cminta = Selection.Areas(1): Set cter = Selection.Areas(2)
  ' Else
  ' Set cminta = Selection.Areas(2): Set cter = Selection.Areas(1)
  ' End If
  Set cter = Range(Cells(3183, 15), Cells(3283, 19)) 'Vizsgáladó terület
  'A Mintaszínek sorra vétele
  For j = 1 To 3
  Set cminta = Range(Cells(20, 14 + j), Cells(20, 14 + j)) 'Mintaszín
  countcl = 0 'Színes cella számláló
  xcolor = cminta.Interior.ColorIndex 'A mintaszín Index száma
  For Each cel In cter.Cells 'Végig vizsgálandó területen
  If cel.DisplayFormat.Interior.ColorIndex = xcolor Then 'Ha egyforma a vizsgált cella és minta színindexe
  countcl = countcl + 1 'Számláló növelése
  End If
  Next cel
  Cells(14, 14 + j) = countcl 'A színből talált darabszám
  'MsgBox countcl
  Next j
  End Sub
  Köszönöm szépen az alapötletet.
  Üdvözlettel:
  KBaj

Új hozzászólás Aktív témák