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

• #8068 Fire/SOUL/CD félisten mr.nagy #8067

  Új Válasz 2010-09-08 09:56:59 #8068

  Ú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

  

  Fire/SOUL/CD

  félisten

  válasz mr.nagy #8067 üzenetére

  Hali!

  Igen, a problémát az okozza, hogy a feltételes formázásnál, nem a hagyományos háttérszín módosítás megy végbe. Én egy teljesen más megközelítést használtam ebben a kódban, azaz én magam írom meg a feltételeket és színezem a cellákat a feltételnek megfelelően. Ez biztosan kifogástalanul működik.
  A makróban 2 dolgot kell megadni(bele is írtam hogy hol), az egyik a tartomány, amiben a kód dolgozik, a másik az eredménytábla bal felső cellája(mert hogy eredménytáblát hoz létre, amit persze módosíthatsz az igényednek megfelelően)
  Ahány feltétel, annyival kell módosítani illetve az eredménytábla kiírását bővíteni/csökkenteni

  Private Sub Worksheet_Change(ByVal Target As Range)
  
  Dim My_Range As Range
  'Itt megadod, hogy milyen tartományban dolgozzon a kód
  Set My_Range = Range("C9:M9")
  Dim My_Dest_Range As Range
  'Itt megadod a kezdőcellát, ahova az eredménytábla kerül
  Set My_Dest_Range = Range("C11")
  
  If Not Intersect(My_Range, Range(Target.Address)) Is Nothing Then
  Call My_Conditions(My_Range, My_Dest_Range)
  End If
  
  End Sub

  Ez pedig Module1-ba kerül

  Sub My_Conditions(My_Range As Range, Dest_Range As Range)
  
  Col1Index = 3
  Col2Index = 4
  Col3Index = 5
  ColEmpty = xlNone
  Col1Num = 0
  Col1Sum = 0
  Col2Num = 0
  Col2Sum = 0
  Col3Num = 0
  Col3Sum = 0
  ColEmptyNum = 0
  ColEmptySum = 0
  
  Application.ScreenUpdating = False
  For Each CurrCell In My_Range
  If CurrCell.Value >= 0 And CurrCell.Value <= 5 Then
  CurrCell.Interior.ColorIndex = Col1Index
  Col1Num = Col1Num + 1
  Col1Sum = Col1Sum + CurrCell.Value
  ElseIf CurrCell.Value > 5 And CurrCell.Value <= 7 Then
  CurrCell.Interior.ColorIndex = Col2Index
  Col2Num = Col2Num + 1
  Col2Sum = Col2Sum + CurrCell.Value
  ElseIf CurrCell.Value > 7 And CurrCell.Value <= 10 Then
  CurrCell.Interior.ColorIndex = Col3Index
  Col3Num = Col3Num + 1
  Col3Sum = Col3Sum + CurrCell.Value
  Else: CurrCell.Interior.ColorIndex = xlNone
  ColEmptyNum = ColEmptyNum + 1
  ColEmptySum = ColEmptySum + CurrCell.Value
  End If
  Next CurrCell
  
  Dest_Range.Select
  ActiveCell(1, 1) = "Piros cella darabszám"
  ActiveCell(1, 2) = Col1Num
  ActiveCell(2, 1) = "Piros cella összeg"
  ActiveCell(2, 2) = Col1Sum
  ActiveCell(3, 1) = "Zöld cella darabszám"
  ActiveCell(3, 2) = Col2Num
  ActiveCell(4, 1) = "Zöld cella összeg"
  ActiveCell(4, 2) = Col2Sum
  ActiveCell(5, 1) = "Kék cella darabszám"
  ActiveCell(5, 2) = Col3Num
  ActiveCell(6, 1) = "Kék cella összeg"
  ActiveCell(6, 2) = Col3Sum
  ActiveCell(7, 1) = "Színtelen cella darabszám"
  ActiveCell(7, 2) = ColEmptyNum
  ActiveCell(8, 1) = "Színtelen cella összeg"
  ActiveCell(8, 2) = ColEmptySum
  
  Application.ScreenUpdating = True
  
  End Sub

  Fire.

  [ Szerkesztve ]

  Mindenki tudja, hogy bizonyos dolgokat nem lehet megvalósítani, mígnem jön valaki, aki erről nem tud, és megvalósítja. (Albert Einstein)

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