Kabaka123
15.05.20,09: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.
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,11: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,12: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,18:20
Tak pre zmenu som sa zase ja niečo naučil :D.
Kabaka123
16.05.20,07: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,09: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
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,10: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,13:14
čo ti nefunguje? Nič nemusíš meniť.
Kabaka123
16.05.20,13:33
Aplikovala som, nefunguje. Podfarbuje ako che. VTvojom priloženom súbore nie je makro.
marjankaj
16.05.20,14:03
v pôvodnom dokumente si mala "neop." s bodkou a s bodkou je to aj v makre.
Vyhoď z makra tú bodku.
Vyhoď z makra tú bodku.
Kabaka123
16.05.20,14:09
Teraz už funguje. len preklad nie.
DOPLNENIE: Zmenila som Preklad - podfarbenie bunky na podfarbenie textu. Teraz to už funguje.
DOPLNENIE: Zmenila som Preklad - podfarbenie bunky na podfarbenie textu. Teraz to už funguje.
marjankaj
16.05.20,14:14
ten preklad nefunguje. neviem prečo. veď si nahraj makro.
Poprehadzovala si texty a aj pridala.
Skús opravené.
Poprehadzovala si texty a aj pridala.
Skús opravené.
Kabaka123
16.05.20,14:22
DOPLNENIE2
Jasné doplnením a odstránením riadkov podfarbuje inak, lenže ja neviem dopredu, koľko bude čísel na sále.
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,16: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
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,16: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?
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,16: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"
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,16: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ť?
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,17: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.
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,17: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.
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,20: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
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,10: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
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