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

• matekmatika tag

  #1969

  #1954 Dictator^

  2007-02-03 14:56:12

  Új Válasz

  Ú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

  

  matekmatika

  tag

  #1954 Dictator^

  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]

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