konto usunięte

Temat: Usprawnienie makra w WORD

Wspólnymi siłami wraz z członkami "elektrody" stworzyliśmy makro, które wstawia twardą spację a właściwie są to dwa makra, chciałbym je zitegrować w jedno, i jeżeli to możliwe usprawnić jego procedurę ?
Czy mogę liczyć na Pani pomoc ?

Tekst samego marka ponizej:

Sub Wstaw_twarda_spacje()

' Wstaw_twarda_spacje Makro
' Makro wstawia twardą spację przed wszystkimi spójnikami wymienionymi w kodzie źródłowym,
' spójniki można dodać przez modyfikację kodu źródłowego makra, usuwa wpierw spację wielokrotną w dokumencie.
' Chr(32) - jest to zwykła spacja, natomiast Chr(160) jest to spacja nie rozdzielająca.

' Wyjustuj

Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify

' Usunięcie spacji wielokrotnej

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = " "
.Replacement.Text = " "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute
End With
While Selection.Find.Found()
Selection.Find.Execute Replace:=wdReplaceAll
Wend

' Deklaracja tablicy przyimków i zaimków, które należy poprawić wstawia twardą spację PO wyrazie
Dim a As Byte
Dim dane As New Collection
dane.Add"a"
dane.Add"i"
dane.Add"oraz"
dane.Add"albo"
dane.Add"bądź"
dane.Add"czy"
dane.Add"lub"
dane.Add"ani"
dane.Add"ni"
dane.Add"ale"
dane.Add"lecz"
dane.Add"zaś"
dane.Add"czyli"
dane.Add"przeto"
dane.Add"tedy"
dane.Add"więc"
dane.Add"zatem"
dane.Add"do"
dane.Add"za"
dane.Add"od"
dane.Add"na"
dane.Add"po"
dane.Add"o"
dane.Add"u"
dane.Add"z"
dane.Add"w"
dane.Add"bez"
dane.Add"pod"
dane.Add"nad"
dane.Add"znad"
dane.Add"poprzez"
dane.Add"sprzed"
dane.Add"zza"
dane.Add"mgr"
dane.Add"inż."
dane.Add"dr"
dane.Add"lek."
dane.Add"dent."
dane.Add"mjr"
dane.Add"gen"
dane.Add"hab."
dane.Add"prof."
dane.Add"zw."
dane.Add"ndzw."
dane.Add"lic."
dane.Add"ppor"
dane.Add"pplk"
dane.Add"ja"
dane.Add"ty"
dane.Add"my"
dane.Add"wy"
dane.Add"oni"
dane.Add"one"
dane.Add"mój"
dane.Add"twój"
dane.Add"nasz"
dane.Add"wasz"
dane.Add"ich"
dane.Add"jego"
dane.Add"jej"
dane.Add"ten"
dane.Add"ta"
dane.Add"to"
dane.Add"tamten"
dane.Add"tam"
dane.Add"tu"
dane.Add"ów"
dane.Add"tędy"
dane.Add"taki"
dane.Add"ci"
dane.Add"tamci"
dane.Add"owi"
dane.Add"razy"
dane.Add"tylko"
dane.Add"nie"
dane.Add"by"
dane.Add"niech"
dane.Add"niechaj"
dane.Add"tak"
dane.Add"bodaj"
dane.Add"oby"
dane.Add"A"
dane.Add"I"
dane.Add"Oraz"
dane.Add"Albo"
dane.Add"Bądź"
dane.Add"Czy"
dane.Add"Lub"
dane.Add"Ani"
dane.Add"Ni"
dane.Add"Ale"
dane.Add"Lecz"
dane.Add"Zaś"
dane.Add"Czyli"
dane.Add"Przeto"
dane.Add"Tedy"
dane.Add"Więc"
dane.Add"Zatem"
dane.Add"Do"
dane.Add"Za"
dane.Add"Od"
dane.Add"Na"
dane.Add"Po"
dane.Add"O"
dane.Add"U"
dane.Add"Z"
dane.Add"W"
dane.Add"Bez"
dane.Add"Pod"
dane.Add"Nad"
dane.Add"Znad"
dane.Add"Poprzez"
dane.Add"Sprzed"
dane.Add"Zza"
dane.Add"Mgr"
dane.Add"Inż."
dane.Add"Dr"
dane.Add"Lek."
dane.Add"Dent."
dane.Add"Mjr"
dane.Add"Gen"
dane.Add"Hab."
dane.Add"Prof."
dane.Add"Zw."
dane.Add"Ndzw."
dane.Add"Lic."
dane.Add"Ppor"
dane.Add"Pplk"
dane.Add"Ja"
dane.Add"Ty"
dane.Add"My"
dane.Add"Wy"
dane.Add"Oni"
dane.Add"One"
dane.Add"Mój"
dane.Add"Twój"
dane.Add"Nasz"
dane.Add"Wasz"
dane.Add"Ich"
dane.Add"Jego"
dane.Add"Jej"
dane.Add"Ten"
dane.Add"Ta"
dane.Add"To"
dane.Add"Tamten"
dane.Add"Tam"
dane.Add"Tu"
dane.Add"Ów"
dane.Add"Tędy"
dane.Add"Taki"
dane.Add"Ci"
dane.Add"Tamci"
dane.Add"Owi"
dane.Add"Razy"
dane.Add"Tylko"
dane.Add"Nie"
dane.Add"By"
dane.Add"Niech"
dane.Add"Niechaj"
dane.Add"Tak"
dane.Add"Bodaj"
dane.Add"Oby"

' Procedura wykonująca poprawkę

For a = 1 To dane.Count
With Selection.Find
.Text = dane(a)
.Replacement.Text = dane(a) & Chr$(160)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
With Selection.Find
.Text = dane(a) & Chr$(160) & Chr(32)
.Replacement.Text = dane(a) & Chr$(160)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
Next a
End Sub

Option Explicit
Sub Test()
Dim strListSep As String
strListSep = Application.International(wdListSeparator)
If Spaces2Space(strListSep) Then
If CyfraJednostka(strListSep) Then
If ThousandsSeparator160(strListSep) Then
MsgBox "Koniec...."
End If
End If
End If
End Sub
''---------------------------
Function CyfraJednostka(ByVal sListSep As String) As Boolean
' 160
On Error GoTo CyfraJednostka_Error
Dim arrJedn
Dim a As Long
Dim strRepla As String
arrJedn = VBA.Array("cl", "cm", "dl", "dm", "g", "hl", "sk", _
"kg", "km", "ks", "l", "m", "mg", "ml", "mm", "t", "zł", "gr")
For a = 0 To UBound(arrJedn, 1)
strRepla = "([0-9]){1" & sListSep & "}(" & arrJedn(a) & ")>"
Selection.HomeKey wdStory
With Selection
.Find.ClearFormatting
.Find.Replacement.ClearFormatting
With .Find
.Text = strRepla ' xxxx "([0-9]){1;}(cl)>"
.Replacement.Text = "1^s2"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
End With
Next
CyfraJednostka = True
'---------------------
CyfraJednostka_Exit:
On Error Resume Next
Exit Function

CyfraJednostka_Error:
MsgBox "Błąd Nr: " & Err.Number & vbNewLine & _
"Opis błędu:" & Err.Description & vbNewLine & _
"Procedura CyfraJednostka "
Resume CyfraJednostka_Exit
End Function

'---------------------------
Function Spaces2Space(ByVal sListSep As String) As Boolean
' spacje
On Error GoTo Spaces2Space_Error
Dim strRepla As String
strRepla = "[ ]([ ]){1" & sListSep & "}"
Selection.HomeKey wdStory
With Selection
.Find.ClearFormatting
.Find.Replacement.ClearFormatting
With .Find
.Text = strRepla ' **** "[ ]([ ]){1;}"
.Replacement.Text = "1"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
End With
Spaces2Space = True
'---------------------
Spaces2Space_Exit:
On Error Resume Next
Exit Function

Spaces2Space_Error:
MsgBox "Błąd Nr: " & Err.Number & vbNewLine & _
"Opis błędu:" & Err.Description & vbNewLine & _
"Procedura Spaces2Space "
Resume Spaces2Space_Exit
End Function

'---------------------------
Function ThousandsSeparator160(ByVal sListSep As String) As Boolean
On Error GoTo ThousandsSeparator160_Error
Dim strRepla As String
strRepla = "<([0-9]{1" & sListSep & "}) ([0-9]{1" & sListSep & "})"
Selection.HomeKey wdStory
With Selection
.Find.ClearFormatting
.Find.Replacement.ClearFormatting
With .Find
.Text = strRepla ' **** "<([0-9]{1;}) ([0-9]{1;})"
.Replacement.Text = "1^s2"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
End With
ThousandsSeparator160 = True
'---------------------
ThousandsSeparator160_Exit:
On Error Resume Next
Exit Function

ThousandsSeparator160_Error:
MsgBox "Błąd Nr: " & Err.Number & vbNewLine & _
"Opis błędu:" & Err.Description & vbNewLine & _
"Procedura ThousandsSeparator160 "
Resume ThousandsSeparator160_Exit
End Function
Oskar Shon

Oskar Shon Dodatki do Office
www.VBATools.pl

Temat: Usprawnienie makra w WORD

Panie kolego no fajnie, fajnie ale w kodzie jest pętla która zawiesza realizacje pierwszej procedury i nic nie wnosi do realizacji celu. Należy ją usunąć:
While Selection.Find.Found()
Selection.Find.Execute Replace:=wdReplaceAll
Wend


Poza tym polecenie
Option Explicit
powinno być na samej górze. Zapewne kopiowałeś to z 2ch różnych plików wiec stąd ta pomyłka.

Trzecia innowacja to przywołanie drugiej procedury w pierwszej.
czyli pod koniec procedury Wstaw_twarda_spacje należy wpisać
Call Test
i po jej skończeniu odpali się druga.

konto usunięte

Temat: Usprawnienie makra w WORD

ok, poprawiłem, jak wejdę w wordzie w zakłade uruchom makro - pojawiają mi się dwa

wstaw twardą spację

test

jak zrobić, żeby było widoczne tylko jedno ?

Chciałbym, żeby tekst " nie mrugał" jak makro zaczyna go poprawiać - jest na to jakaś procedura ?
Damian Zurawski

Damian Zurawski Data Engineer w
Grupie Żywiec

Temat: Usprawnienie makra w WORD

Kamilu,

Za "mruganie" odpowiada procedura Application.ScreenUpdating

Przed procedura poprawiajaca znaki wstaw Application.ScreenUpdating = False
a po zakonczeniu jej dzialania wstaw Application.ScreenUpdating = True
Oskar Shon

Oskar Shon Dodatki do Office
www.VBATools.pl

Temat: Usprawnienie makra w WORD

Kamil Z.:
jak zrobić, żeby było widoczne tylko jedno ?

No to dopowiem:
Aby było niewidoczne do procedury dodaj oznaczenie
Private Sub test()

Zapraszam na VBATools.pl -> tam znajdziesz dla siebie dodatki do Office.Ten post został edytowany przez Autora dnia 30.10.14 o godzinie 14:41

konto usunięte

Temat: Usprawnienie makra w WORD

Dzięki Panowie,
rozpoczynam dystrybucję makra wśród studentów mojej uczelni :)

Następna dyskusja:

Excel - Microsoft 2007 - V...




Wyślij zaproszenie do