Kabaka123
15.05.20,10:00
word 2007

Potrebujem použiť makro vo worde.

Predtým sa makro používalo v exceli, ale došlo k zmene spracovávaniu dát.

Tabuľka sa vytvorí klasickým kopírovaním a vložením. Potrebujem podľa premennej DODATOK,SLUžBA, PRíSLUžBA NEOP a PREKLAD. podfarbiť celý riadok.(pôvodne len bunku)

Ešte riešim podfarbenie prázdnych riadkov - oddelovačov medzi sálamil

DOPLNENIE Makro na podfarbenie prázdnych riadkov oddeľovačov medzi sálami funguje.
DOPLNENIE2 Makro formát funguje na konkrétny počet riadkov.

Zmenila som PREKLAD na podfarbenie riadku, lebo s podfarbením bunky mi to nefungovalo.
Pridaním a odstránením riadkov makro reaguje inak, lenže ja dopredu neviem, koľko riadkov, či sál a čísel na sále, a kde budú aké poznámky, to bol len názorný príklad, čo všetko sa tam môže vyskytnúť.

Je možné doplniť príkaz: najprv spočítaj riadky a potom aplikuj makro. Šlo by to?

DOPLNENIE3 počítanie riadkov pridané, makro format a farba spojené dokopy.



Sub formatafarba()


Dim i As Long, j As Long, k As Long, d As Long
With ActiveDocument
For i = 1 To .Tables.Count
With .Tables(i)
For j = 1 To .Rows.Count
With .Rows(j)
d = 0
For k = 1 To .Cells.Count
d = Len(.Cells(k).Range) + d
Next k
If d < 31 Then .Shading.BackgroundPatternColor = wdColorYellow
End With
Next j
End With
Next i
End With


Application.ScreenUpdating = False
a = Array("dodatok", "príslužba", "služba", "neop.", "preklad")
b = Array(wdColorGreen, wdColorBlue, wdColorBlue, wdColorRed, wdColorPlum)
For j = 0 To 4
For i = 1 To 17
With Selection.Find
.ClearFormatting
.Text = a(j)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.MatchWholeWord = True
.Execute
End With


With Selection
.HomeKey Unit:=wdLine
.MoveLeft Count:=14, Extend:=wdExtend
.Font.Color = b(j)
.Font.Bold = True
.MoveDown Unit:=wdLine, Count:=1
End With
Next i
Next j


Application.ScreenUpdating = True


End Sub




VYRIEŠENÉ Funguje.

DOPLNENIE4
Som si uvedomila že For i = 1 To 74, je blbosť.
Zmenila som na 10. Je predpoklad, že viac ako počet 5 nebude.
(Viac ako 5 dodatkov, 5 neop., 5 príslužba, 5 služba, 5 príslužba )
Možno by stačilo aj 5.

Prepočet sa zrýchlil.
misoft
15.05.20,12:18
No ja si myslím, že pre vložené tabuľky (excelovské) vo worde makrá nefungujú. A makrá pre word nebudú fungovať vo vloženej tabuľke. Tie tabuľky sú jednoduché, bez uplatňovania makier.
Kabaka123
15.05.20,13:13
Časť funkčného makra už mám. A súbor musí mať koncovku docm. Inak makrá nefungujú. Koncovka docm nie je na porade podporovaná.
misoft
15.05.20,19:20
Tak pre zmenu som sa zase ja niečo naučil :D.
Kabaka123
16.05.20,08:41
Kurzíva, výška 0,5 a font 9 sa môže nastaviť aj manuálne. Rozhodla som sa, že sa sály oddelia podfarbením celého riadka, ktorých ich oddeľuje, to bude stačiť.
marjankaj
16.05.20,10:09
Sub aaaab()

Application.ScreenUpdating = False

a = Array("dodatok", "príslužba", "služba", "neop")
b = Array(wdColorGreen, wdColorBlue, wdColorBlue, wdColorRed)
For j = 0 To 3
Selection.GoTo What:=wdGoToLine, Which:=wdGoToFirst, Count:=1, Name:=""
For i = 1 To 20
With Selection.Find
.ClearFormatting
.Text = a(j)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.MatchWholeWord = True
.Execute
End With

With Selection
.HomeKey Unit:=wdLine
.MoveLeft Count:=14, Extend:=wdExtend
.Font.Color = b(j)
.Font.Bold = True
.MoveDown Unit:=wdLine, Count:=1
End With
Next i
Next j

' podfarbenie preklad
Selection.Find.ClearFormatting
With Selection.Find
.Text = "preklad"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = True
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With

Selection.Shading.Texture = wdTextureNone
Selection.Shading.ForegroundPatternColor = wdColorAutomatic
Selection.Shading.BackgroundPatternColor = -603923969

Application.ScreenUpdating = True
End Sub

Sub Makro5b()
' podfarbenie preklad
Selection.Find.ClearFormatting
With Selection.Find
.Text = "preklad"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = True
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With

Selection.Shading.Texture = wdTextureNone
Selection.Shading.ForegroundPatternColor = wdColorAutomatic
Selection.Shading.BackgroundPatternColor = -603923969
End Sub
Kabaka123
16.05.20,11:23
Ďakujem, vyskúšala som. Nefunguje spoľallivo, Mením čísla hore dole. Musím teda upustiť od makra, kde budú premenné spolu, budem ich spúšťať samostatne.
marjankaj
16.05.20,14:14
čo ti nefunguje? Nič nemusíš meniť.
Kabaka123
16.05.20,14:33
Aplikovala som, nefunguje. Podfarbuje ako che. VTvojom priloženom súbore nie je makro.
marjankaj
16.05.20,15:03
v pôvodnom dokumente si mala "neop." s bodkou a s bodkou je to aj v makre.
Vyhoď z makra tú bodku.
Kabaka123
16.05.20,15:09
Teraz už funguje. len preklad nie.
DOPLNENIE: Zmenila som Preklad - podfarbenie bunky na podfarbenie textu. Teraz to už funguje.
marjankaj
16.05.20,15:14
ten preklad nefunguje. neviem prečo. veď si nahraj makro.
Poprehadzovala si texty a aj pridala.
Skús opravené.
Kabaka123
16.05.20,15:22
DOPLNENIE2
Jasné doplnením a odstránením riadkov podfarbuje inak, lenže ja neviem dopredu, koľko bude čísel na sále.
marjankaj
16.05.20,17:06
Sub podfarbiprazdnebunkyzltou()
Dim i As Long, j As Long, k As Long, d As Long
With ActiveDocument
For i = 1 To .Tables.Count
With .Tables(i)
For j = 1 To .Rows.Count
With .Rows(j)
d = 0
For k = 1 To .Cells.Count
d = Len(.Cells(k).Range) + d
Next k
If d < 31 Then .Shading.BackgroundPatternColor = wdColorYellow
End With
Next j
End With
Next i
End With
End Sub
Kabaka123
16.05.20,17:20
Ok toto makro na podfarbenie buniek žltou funguje. Ďakujem.
Je možné doriešiť predchádzajúce makro?
Nejakým príkazom, najprv spočítaj riadky a potom aplikuj formát?
marjankaj
16.05.20,17:27
veď rows.count.
Ale ak je viac tabuliek tak treba počítať za všetky.
Ale lepšie je spočítať počet tých slov napr."neop"
Kabaka123
16.05.20,17:33
Idem otestovať. Ok, dala som to dokopy, zdá sa, že to funguje, pridám ešte riadky.
Pridala som spojené makro do otázky

Len otázočka, teraz For i = 1 To 17 má teraz nejaký význam? Mám to vyhodiť?
marjankaj
16.05.20,18:06
no to je počet "dodatok"
počet "neop" je 20
nechať to cyklovať na počet riadkov je zbytočné predlženie výpočtu.
možno niekto dá efektívnejšie riešenie. Ja makrá vo worde veľmi neovládam.
Kabaka123
16.05.20,18:13
Ok jasné.
Vystačím si teda s tým čo mám.

Urobila som si prepočet sál.

Viac ako 74 riadkov by to nemalo byť.(aj s prázdymi riadkami - celá tabuľka)
Ak budú mať všetky sály po tri čísla a dve sály po 10.

17 som nahradila 74(ako riadky) teraz to funguje celkom dobre.
marjankaj
16.05.20,21:54
No tu netreba počítať riadky, ale tiež to ide dlho:eek:


Sub podfarbiprazdnebunkyzltou()
Dim i As Long, j As Long, k As Long, m As Long, d As Long, x As String
Application.ScreenUpdating = False
a = Array("dodatok", "príslužba", "služba", "neop")
b = Array(wdColorGreen, wdColorBlue, wdColorBlue, wdColorRed)
With ActiveDocument
For i = 1 To .Tables.Count
With .Tables(i)
For j = 1 To .Rows.Count
With .Rows(j)

' vyfarbenie PREKLAD
x = Left(.Cells(.Cells.Count), 16)
x = Left(x, Len(x) - 2)
If x = "preklad" Then .Cells(.Cells.Count).Shading.BackgroundPatternColo r = wdColorLightGreen
' vyfarbenie riadkov
For m = 0 To 3
If x = a(m) Then .Select
With Selection
.Font.Color = b(m)
.Font.Bold = True
End With
Next m

' oddelenie sál
d = 0
For k = 1 To .Cells.Count
d = Len(.Cells(k).Range) + d
Next k
If d < 31 Then .Shading.BackgroundPatternColor = wdColorYellow


End With
Next j

End With
Next i
End With
Application.ScreenUpdating = True
End Sub
Kabaka123
17.05.20,11:29
Vyskúšam aj toto,,
Doplnila som otázku, nakoniec som to obmedzila na 5.

Ešte technická otázoočka: akú wdColorGray? mám zvoliť, aby bola poradne vyditeľná? Teraz mám namiesto nej BlueGray

https://docs.microsoft.com/en-us/office/vba/api/word.wdcolor