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

• #11731 Fire/SOUL/CD félisten sonar #11730

  Új Válasz 2011-10-17 15:48:25 #11731

  Ú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 sonar #11730 üzenetére

  Berakom ezt a makrót is, ha másért nem, hátha mások találnak benne a későbbiekben hasznosítható ötletet.

  

  Private Sub CommandButton1_Click()
  
  'FSCD_MIN_MAX_With_Unique Macro
  
  Dim MyCell As Range
  Dim MyCollection As New Collection
  Dim MyValue As Variant
  Dim MyTypeSrcRange As Range, MyTimeSrcRange As Range, MyDestRange As Range
  Dim MyTypeColumnRow As Range, MyTimeColumnRow As Range
  Dim MySrcColumn As String
  Dim MySrcRow As Integer
  Dim MyFxs As WorksheetFunction
  Set MyFxs = Application.WorksheetFunction
  
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  
  'A TÍPUS adatok ettől a cellától kezdődnek
  Set MyTypeColumnRow = Range("A2")
  'Az IDŐ adatok ettől a cellától kezdődnek
  Set MyTimeColumnRow = Range("B2")
  'Az elkészítendő TÁBLÁZAT kezdőcellája (táblázat bal-felső sarka)
  Set MyDestRange = Range("C2")
  
  Set MyTypeSrcRange = Range(MyTypeColumnRow.Address & ":" & Chr(MyTypeColumnRow.Column + 64) & Cells(Rows.Count, Chr(MyTypeColumnRow.Column + 64)).End(xlUp).Row)
  Set MyTimeSrcRange = Range(MyTimeColumnRow.Address & ":" & Chr(MyTimeColumnRow.Column + 64) & Cells(Rows.Count, Chr(MyTimeColumnRow.Column + 64)).End(xlUp).Row)
  
  For Each MyCell In MyTypeSrcRange
  On Error Resume Next
  MyCollection.Add MyCell.Value, CStr(MyCell.Value)
  Next MyCell
  
  i = 1
  MyDestRange.Offset(0, 0) = "Típus"
  MyDestRange.Offset(0, 1) = "MIN"
  MyDestRange.Offset(0, 2) = "MAX"
  
  For Each MyValue In MyCollection
  MyDestRange.Offset(i, 0).NumberFormat = "@"
  MyDestRange.Offset(i, 0) = MyValue
  MyDestRange.Offset(i, 1).NumberFormat = "[h]:mm:ss"
  MyDestRange.Offset(i, 1).FormulaArray = "=MIN(IF(" & MyTypeSrcRange.Address & "=""" & MyDestRange.Offset(i, 0) & """," & MyTimeSrcRange.Address & "))"
  MyDestRange.Offset(i, 2).NumberFormat = "[h]:mm:ss"
  MyDestRange.Offset(i, 2).FormulaArray = "=MAX(IF(" & MyTypeSrcRange.Address & "=""" & MyDestRange.Offset(i, 0) & """," & MyTimeSrcRange.Address & "))"
  i = i + 1
  Next MyValue
  
  Set MyTypeSrcRange = Nothing
  Set MyTimeSrcRange = Nothing
  Set MyDestRange = Nothing
  Set MyTypeColumnRowe = Nothing
  Set MyTimeColumnRowe = Nothing
  Set MyCollection = Nothing
  
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  
  End Sub

  [ 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