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

• #1969 matekmatika tag Dictator^ #1954

  Új Válasz 2007-02-03 14:56:12 #1969

  Ú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

  

  matekmatika

  tag

  válasz Dictator^ #1954 üzenetére

  Visszatérve egy korábbi hozzászólásodra, hogy annyira nem lehet nehéz megcsinálni..., lehet, hogy van akinek nem. Nekem azért kellett vele bírkozni egy kicsit. Nem lehetett volna a tételeket cellánként kezelni?
  Itt a végeredmény, hozz létre egy új makrót és illeszd be:
  
  Sub Szinezos()
  'Hivatkozni szeretnék majd az aktuális munkalapra
  'és mivel nem tudom mi most a neve nálad ezért
  'először átnevezem ''Tételek''-re
  ActiveSheet.Name = ''Tételek''
  
  'Az utolsó sor száma
  sor = ActiveSheet.UsedRange.Rows.Count
  
  'Az utolsó oszlop száma
  oszlop = ActiveSheet.UsedRange.Columns.Count
  
  'Alapértelmezett szín
  szin = 0
  
  'Létrehozunk egy segéd munkalapot
  Worksheets.Add.Name = ''seged''
  
  'melyre a ''seged''-del fogunk hivatkozni
  Set seged = Worksheets(''seged'')
  
  'Aktívvá tesszük ismét a Munka1-t
  Worksheets(''Tételek'').Activate
  
  x = 0
  
  'Két ciklussal végigmegyünk a cellákon
  For j = 1 To oszlop
  For i = 1 To sor
  
  'aktuális cella
  cella = Cells(i, j)
  
  'cella karaktereinek száma
  h = Len(cella)
  
  ''',''-t keres a szövegben
  a = InStr(cella, '','')
  
  'Ha nincs ''a'' értéke: 0 lesz
  'Ha van akkor '','' pozícióját adja
  
  If a > 0 Then
  elso = Left(cella, a - 1)
  masodik = Right(cella, h - a - 1)
  
  'Ha nem talál '',''-t a beírt szövegben
  Else
  
  'Akkor az első legyen maga a cella tartalma
  elso = cella
  
  'Második tétel pedig nincs
  masodik = 0
  End If
  
  'A kapott tételeket eltároljuk a segéd munkalapon
  If elso <> Empty Then
  x = x + 1
  seged.Cells(x, 1) = elso
  End If
  If masodik <> Empty Then
  x = x + 1
  seged.Cells(x, 1) = masodik
  End If
  Next i
  Next j
  
  'Tételek átnézése azonosak megjelölése
  Application.ScreenUpdating = False
  Sheets(''seged'').Select
  Columns(''A:A'').Select
  Selection.Sort Key1:=Range(''A:A''), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
  False, Orientation:=xlTopToBottom
  Do While Cells(1, 1) = Empty
  Cells(1, 1).Select
  Selection.Delete Shift:=xlUp
  Loop
  a = 2
  b = 1
  Cells(1, 2) = Cells(1, 1)
  Do While Cells(a, 1) <> Empty
  If Cells(a + 1, 1) = Cells(b, 2) Then
  Cells(b, 3) = Cells(b, 3) + 1
  Else
  Cells(b + 1, 2) = Cells(a + 1, 1)
  Cells(b, 3) = Cells(b, 3) + 1
  b = b + 1
  End If
  a = a + 1
  Loop
  Sheets(''Tételek'').Select
  i = 1
  szin = 2
  Do While seged.Cells(i, 2) <> Empty
  If seged.Cells(i, 3) > 1 Then
  For j = 1 To sor
  For k = 1 To oszlop
  cella = Cells(j, k)
  If cella Like ''*'' & seged.Cells(i, 2) & ''*'' Then
  kezd = InStr(cella, seged.Cells(i, 2))
  hossz = Len(seged.Cells(i, 2))
  h = InStr(cella, '','')
  If h > 0 Then
  With Cells(j, k).Characters(Start:=kezd, Length:=hossz).Font
  .FontStyle = ''Félkövér''
  .ColorIndex = szin
  End With
  If Left(cella, h - 1) = Right(cella, Len(cella) - h - 1) Then
  With Cells(j, k).Font
  .FontStyle = ''Félkövér''
  .ColorIndex = szin
  End With
  End If
  Else
  With Cells(j, k).Font
  .FontStyle = ''Félkövér''
  .ColorIndex = szin
  End With
  End If
  End If
  Next k
  Next j
  End If
  i = i + 1
  szin = szin + 1
  Loop
  Application.ScreenUpdating = True
  Application.DisplayAlerts = False
  Worksheets(''seged'').Delete
  Application.DisplayAlerts = True
  End Sub
  
  vagy dolgozd át ezt, itt megnézheted konkrétan mit csinál: [link]
  
  [Szerkesztve]

• #1955 matekmatika tag Dictator^ #1954

  Új Válasz 2007-02-01 11:29:53 #1955

  Ú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

  

  matekmatika

  tag

  válasz Dictator^ #1954 üzenetére

  Sajnos majd csak délután lesz időm rá.
  2 kérdés:
  Mindíg így kettesével szereplenek?
  Ill. ha igen akkor mindíg vesszővel vannak elválasztva?
  
  Mert ha igen akkor jó. (Ha nem akkor nehéz lesz kitalálnia meddig tart egy tétel).

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