-
Fototrend
A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
Kérdés felvetése előtt olvasd el, ha még nem tetted.
Új hozzászólás Aktív témák
-
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]
Új hozzászólás Aktív témák
- World of Tanks - MMO
- Otthoni hálózat és internet megosztás
- Ukrajnai háború
- Stellar Blade
- AMD off topik: VGA, CPU, APU és minden, ami AMD
- AMD K6-III, és minden ami RETRO - Oldschool tuning
- Így építsd a billentyűzeted!
- Linux felhasználók OFF topikja
- Bemutatkozott a Moto G32 4G
- Luck Dragon: MárkaLánc
- További aktív témák...
Állásajánlatok
Cég: Ozeki Kft.
Város: Debrecen
Cég: Promenade Publishing House Kft.
Város: Budapest