Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
Przesunięty przez: Artik
28-02-2020, 01:00
Automatyczne wypełnianie szablonu Word
Autor Wiadomość
Twinkle 
Starszy Forumowicz


Posty: 32
Wysłany: 27-02-2020, 14:50   Automatyczne wypełnianie szablonu Word

Witam.
Używam następującego kodu do automatycznego wypełniania szablonu w Wordzie - kod pobiera dane na podstawie nazw zakładek z wiersza nr 1 (imię, nazwisko, itp - komórki z danymi od A2 w prawo), wstawia w pola tekstowe formularza w Wordzie, potem zapisuje plik z odpowiednią nazwą, tworzoną na podstawie komórek B2 i C2.

Chciałbym to zmodyfikować tak, żeby:

Opcja 1:
Dane pobrane były z większej niż tylko jeden ilości wierszy i zapisało kilka dokumentów Word (z nazwami na podstawie B2/C2 - dane od A2 w prawo, B3/C3 - dane od A3 w prawo itd)

Opcja2:
W przypadku pobierania danych do pojedyńczego szablonu, pobrało dane np od A10 prawo po zaznaczeniu komórki A10.


Jeżeli ktoś ma jakiś pomysł jak to rozwiązać, będę wdzięczny.

Kod:

Sub umowa()
  Dim oWord As Word.Application
  Dim oDoc As Word.Document
  Dim path As String
  Dim rgNazwyZakladek As Range, rgZakladka As Range

  On Error GoTo Except

  path = "c:\users\..."

  Set rgNazwyZakladek = Range("A1", Cells(1, Columns.Count).End(xlToLeft))

  Set oWord = New Word.Application
 
  Set oDoc = oWord.Documents.Add("c:\users\...)
  oWord.Visible = True

  On Error Resume Next
  For Each rgZakladka In rgNazwyZakladek

    oDoc.FormFields(rgZakladka).result = rgZakladka.Offset(1, 0)
  Next
  On Error GoTo Except
  zapamietana_nazwa = path & _
      rgNazwyZakladek(1).Offset(1, 1) & " " & _
      rgNazwyZakladek(1).Offset(1, 2)
oDoc.SaveAs zapamietana_nazwa
   
Dim wdApp As Object 'Word.Application
Dim wdDoc As Object 'Word.Document
 

Except:
  On Error Resume Next
  Set oDoc = Nothing
End Sub
ID posta: 382621 Skopiuj do schowka
 
 
bezet-1147 
Fan Excela


Wersja: Win Office 2007
Pomógł: 19 razy
Posty: 95
Wysłany: 27-02-2020, 18:56   

.
To, czego potrzebujesz załatwia funkcja programu Word pod nazwą "korespondencja seryjna"
[ Menu główne ---> Korespondencja ---> Rozpocznij koresp. ser. ]

Działa to mniej więcej tak:
1____ W Excelu tworzysz bazę danych, w której to bazie, w pierwszym jej wierszu, umieszczasz nadane przez siebie nazwy kolejnych kolumn bazy (będą to tzw. pola korespondencji seryjnej). Na przykład: pole "Nazwisko", pole "Imię", pole "Nazwa firmy", pole "Regon", pole "Adres", pole "Kwota_kredytu", pole "Oprocentowanie" i tak dalej.
2____ W kolejnych wierszach bazy (drugim i następnych) wpisujesz dane dotyczące poszczególnych kontrahentów, stosownie do nazwy pola zawartej w pierwszym wierszu bazy.
3____ W Wordzie tworzysz szablon dokumentu (może to być np. list, może to być np. umowa) i w tym szablonie w stosownych miejscach umieszczasz nazwy poszczególnych pól.
4____ Następnie możesz wybrać (zaznaczyć) jednego kontrahenta, kilku/kilkunastu/kilkudziesięciu kontrahentów lub wybrać (zaznaczyć) wszystkich, a potem uruchomić drukowanie serii dokumentów dla wybranych uprzednio kontrahentów.

---------------------------------
35
.
ID posta: 382648 Skopiuj do schowka
 
 
Twinkle 
Starszy Forumowicz


Posty: 32
Wysłany: 27-02-2020, 19:45   

Wiem jak działa korespondencja seryjna, ale w moim przypadku, gdyby dało się zmodyfikować ten kod VBA (zwłaszcza jak chodzi o opcję nr 2), byłoby to znaczenie wygodniejsze i szybsze w codziennej pracy.
ID posta: 382650 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 2940 razy
Posty: 9714
Wysłany: 28-02-2020, 03:44   

Twinkle napisał/a:
Opcja 1

Kod:
Sub umowa_Wiele()

    Dim wdApp       As Object
    Dim wdDoc       As Object

    Dim strSciezkaZapisu As String
    Dim strSciezkaSzablonu As String
    Dim strNazwaPliku As String
    Dim rgNazwyZakladek As Range
    Dim rgZakladka  As Range
    Dim blnCzyWordOtwarty As Boolean
    Dim i           As Long

    Const wdFormatXMLDocument As Long = 12

    If MsgBox("Czy chcesz wyeksportować wszystkie dokumenty?", vbQuestion + vbYesNo) = vbNo Then
        Exit Sub
    End If

    strSciezkaZapisu = "c:\users\..."

    If Right(strSciezkaZapisu, 1) <> Application.PathSeparator Then
        strSciezkaZapisu = strSciezkaZapisu & Application.PathSeparator
    End If

    strSciezkaSzablonu = "c:\users\...\Dokument Worda.doc lub .dot"

    Set rgNazwyZakladek = Range("A1", Cells(1, Columns.Count).End(xlToLeft))

    On Error Resume Next
    blnCzyWordOtwarty = True
    Set wdApp = GetObject(, "Word.Application")

    If wdApp Is Nothing Then
        blnCzyWordOtwarty = False
        Set wdApp = CreateObject("Word.Application")
    End If

    If wdApp Is Nothing Then
        MsgBox "Coś nie halo z Wordem!", vbCritical
        Exit Sub
    End If


    Do Until rgNazwyZakladek(1).Offset(i + 1).Value = ""
        i = i + 1
        Set wdDoc = Nothing
        Set wdDoc = wdApp.Documents.Add(Template:=strSciezkaSzablonu, _
                                        NewTemplate:=True, _
                                        Visible:=False)
        If wdDoc Is Nothing Then
            MsgBox "Nieudana próba otwarcia szablonu!" & vbLf & _
                   "Działanie makra zostanie przerwane.", vbCritical
            GoTo EndProc
        End If


        For Each rgZakladka In rgNazwyZakladek
            wdDoc.FormFields(rgZakladka).Result = rgZakladka.Offset(i)
            If Err.Number <> 0 Then
                Err.Clear
                MsgBox "Nieudany zapis do zakładki '" & rgZakladka & "'" & vbLf & _
                       "w dokumencie '" & rgNazwyZakladek(1).Offset(i, 1) & " " & _
                       rgNazwyZakladek(1).Offset(i, 2) & "'." & vbLf & _
                       "Ale jedziemy dalej.", vbExclamation
            End If
        Next rgZakladka

        strNazwaPliku = strSciezkaZapisu & _
                        ReplaceIllegalCharacters(rgNazwyZakladek(1).Offset(i, 1), "_") & " " & _
                        ReplaceIllegalCharacters(rgNazwyZakladek(1).Offset(i, 2), "_")

        wdDoc.SaveAs Filename:=strNazwaPliku, FileFormat:=wdFormatXMLDocument
        wdDoc.Close SaveChanges:=False

        If Err.Number <> 0 Then
            Err.Clear
            If MsgBox("Nieudany zapis dokumentu" & vbLf & _
                      "'" & rgNazwyZakladek(1).Offset(i, 1) & " " & _
                      rgNazwyZakladek(1).Offset(i, 2) & "'." & vbLf & _
                      "Czy chcesz przerwać dalsze działanie makra?", _
                      vbExclamation + vbYesNo + vbDefaultButton1) = vbYes Then
                GoTo EndProc
            End If
        End If
    Loop


EndProc:

    If Not blnCzyWordOtwarty Then
        wdApp.Quit
    End If

    Set wdDoc = Nothing
    Set wdApp = Nothing
End Sub


Twinkle napisał/a:
Opcja2
Kod:
Sub umowa_Aktyw()

    Dim wdApp       As Object
    Dim wdDoc       As Object

    Dim strSciezkaZapisu As String
    Dim strSciezkaSzablonu As String
    Dim strNazwaPliku As String
    Dim rgNazwyZakladek As Range
    Dim Rng  As Range
    Dim blnCzyWordOtwarty As Boolean
    Dim blnPrzerwij As Boolean
    Dim i           As Long

    Const wdFormatXMLDocument As Long = 12

    Set rgNazwyZakladek = Range("A1", Cells(1, Columns.Count).End(xlToLeft))

    Set Rng = Intersect(ActiveCell, Cells(1).CurrentRegion)
    blnPrzerwij = False

    If Rng Is Nothing Then
        blnPrzerwij = True
    ElseIf Not Intersect(ActiveCell, rgNazwyZakladek) Is Nothing Then
        blnPrzerwij = True
    End If

    If blnPrzerwij Then
        MsgBox "Zaznacz komórkę w zakresie danych!", vbExclamation
        Exit Sub
    End If

    i = ActiveCell.Row - 1

    If MsgBox("Czy chcesz wyeksportować dane dla ' " & _
              rgNazwyZakladek(1).Offset(i, 1) & " " & _
              rgNazwyZakladek(1).Offset(i, 2) & "'?", _
              vbQuestion + vbYesNo + vbDefaultButton1) = vbNo Then
        Exit Sub
    End If

    strSciezkaZapisu = "c:\users\..."

    If Right(strSciezkaZapisu, 1) <> Application.PathSeparator Then
        strSciezkaZapisu = strSciezkaZapisu & Application.PathSeparator
    End If

    strSciezkaSzablonu = "c:\users\...\Dokument Worda.doc lub .dot"

    On Error Resume Next
    blnCzyWordOtwarty = True
    Set wdApp = GetObject(, "Word.Application")

    If wdApp Is Nothing Then
        blnCzyWordOtwarty = False
        Set wdApp = CreateObject("Word.Application")
    End If

    If wdApp Is Nothing Then
        MsgBox "Coś nie halo z Wordem!", vbCritical
        Exit Sub
    End If


    Set wdDoc = Nothing
    Set wdDoc = wdApp.Documents.Add(Template:=strSciezkaSzablonu, _
                                    NewTemplate:=True, _
                                    Visible:=False)
    If wdDoc Is Nothing Then
        MsgBox "Nieudana próba otwarcia szablonu!" & vbLf & _
               "Działanie makra zostanie przerwane.", vbCritical
        GoTo EndProc
    End If


    For Each Rng In rgNazwyZakladek
        wdDoc.FormFields(Rng).Result = Rng.Offset(i)
        If Err.Number <> 0 Then
            Err.Clear
            MsgBox "Nieudany zapis do zakładki '" & Rng & "'" & vbLf & _
                   "w dokumencie '" & rgNazwyZakladek(1).Offset(i, 1) & " " & _
                   rgNazwyZakladek(1).Offset(i, 2) & "'." & vbLf & _
                   "Ale jedziemy dalej.", vbExclamation
        End If
    Next Rng

    strNazwaPliku = strSciezkaZapisu & _
                    ReplaceIllegalCharacters(rgNazwyZakladek(1).Offset(i, 1), "_") & " " & _
                    ReplaceIllegalCharacters(rgNazwyZakladek(1).Offset(i, 2), "_")

    wdDoc.SaveAs Filename:=strNazwaPliku, FileFormat:=wdFormatXMLDocument
    wdDoc.Close SaveChanges:=False

    If Err.Number <> 0 Then
        Err.Clear
        MsgBox "Nieudany zapis dokumentu" & vbLf & _
               "'" & rgNazwyZakladek(1).Offset(i, 1) & " " & _
               rgNazwyZakladek(1).Offset(i, 2) & "'.", _
               vbExclamation
    End If
End If

EndProc:

If Not blnCzyWordOtwarty Then
    wdApp.Quit
End If

Set wdDoc = Nothing
Set wdApp = Nothing
End Sub

Do modułu dodaj też funkcję
Kod:
Function ReplaceIllegalCharacters(strIn As String, strChar As String) As String
    Dim strSpecialChars As String
    Dim i           As Long

    strSpecialChars = "~""#%&*:<>?|/\[]" & Chr(10) & Chr(13)

    For i = 1 To Len(strSpecialChars)
        strIn = Replace(strIn, Mid$(strSpecialChars, i, 1), strChar)
    Next

    ReplaceIllegalCharacters = strIn
End Function

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 382659 Skopiuj do schowka
 
 
Twinkle 
Starszy Forumowicz


Posty: 32
Wysłany: 28-02-2020, 08:50   

@Artik, chapeau bas, właśnie o coś w tym stylu mi chodziło. Wielkie dzięki.

Problem jest (chyba) tylko w końcówce, bo wyskakuje nieudany zapis dokumentu. Testowałeś to może na jakimś przykładzie?
ID posta: 382671 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 2940 razy
Posty: 9714
Wysłany: 28-02-2020, 09:43   

Twinkle napisał/a:
Testowałeś to może na jakimś przykładzie?
A dałeś przykład? Nie. Pisałem na sucho.
Twinkle napisał/a:
bo wyskakuje nieudany zapis dokumentu
Czy, mimo komunikatu, pliki się zapisują?

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 382675 Skopiuj do schowka
 
 
Twinkle 
Starszy Forumowicz


Posty: 32
Wysłany: 28-02-2020, 10:07   

Nie, nie zapisywał, ale już działa. Problemem była ukryta kolumna w arkuszu. Jeszcze raz wielkie dzięki.
ID posta: 382679 Skopiuj do schowka
 
 
Twinkle 
Starszy Forumowicz


Posty: 32
Wysłany: 06-03-2020, 09:48   

@Artik, jeszcze jedno pytanie... W przypadku kodu wypełniającego hurtem da radę uwzględnić, żeby wypełniało tylko dla widocznych, odfiltrowanych wierszy?
ID posta: 383236 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 2940 razy
Posty: 9714
Wysłany: 06-03-2020, 11:00   

Taka nieco partyzantka, by nie robić rewolucji w kodzie.
Jeżeli jest włączony Autofiltr (obojętnie czy przefiltrowano czy nie, wystarczy że włączony) zakres autofiltra jest kopiowany do nowego arkusza i to z niego są czytane dane. Jeżeli nie ma włączonego Autofiltra, dane są czytane z oryginalnego arkusza.
Założono, że na arkuszu NIE ma wstawionej Tabeli (w rozumieniu narzędzia Excela).
Kod:
Sub umowa_Wiele()

    Dim wdApp       As Object
    Dim wdDoc       As Object

    Dim strSciezkaZapisu As String
    Dim strSciezkaSzablonu As String
    Dim strNazwaPliku As String
    Dim rgNazwyZakladek As Range
    Dim rgZakladka  As Range
    Dim blnCzyWordOtwarty As Boolean
    Dim i           As Long
    Dim wksActv As Worksheet
    Dim wksNew As Worksheet
   

    Const wdFormatXMLDocument As Long = 12

    If MsgBox("Czy chcesz wyeksportować wszystkie widoczne dokumenty?", vbQuestion + vbYesNo) = vbNo Then
        Exit Sub
    End If

    strSciezkaZapisu = "c:\users\..."

    If Right(strSciezkaZapisu, 1) <> Application.PathSeparator Then
        strSciezkaZapisu = strSciezkaZapisu & Application.PathSeparator
    End If

    strSciezkaSzablonu = "c:\users\...\Dokument Worda.doc lub .dot"
   
    Set wksActv = ActiveSheet
   
    If wksActv.AutoFilterMode Then
      wksActv.AutoFilter.Range.Copy
      Set wksNew = ThisWorkbook.Worksheets.Add
      wksNew.Paste
    End If

    Set rgNazwyZakladek = Range("A1", Cells(1, Columns.Count).End(xlToLeft))

    On Error Resume Next
    blnCzyWordOtwarty = True
    Set wdApp = GetObject(, "Word.Application")

    If wdApp Is Nothing Then
        blnCzyWordOtwarty = False
        Set wdApp = CreateObject("Word.Application")
    End If

    If wdApp Is Nothing Then
        MsgBox "Coś nie halo z Wordem!", vbCritical
        Exit Sub
    End If


    Do Until rgNazwyZakladek(1).Offset(i + 1).Value = ""
        i = i + 1
        Set wdDoc = Nothing
        Set wdDoc = wdApp.Documents.Add(Template:=strSciezkaSzablonu, _
                                        NewTemplate:=True, _
                                        Visible:=False)
        If wdDoc Is Nothing Then
            MsgBox "Nieudana próba otwarcia szablonu!" & vbLf & _
                   "Działanie makra zostanie przerwane.", vbCritical
            GoTo EndProc
        End If


        For Each rgZakladka In rgNazwyZakladek
            wdDoc.FormFields(rgZakladka).Result = rgZakladka.Offset(i)
            If Err.Number <> 0 Then
                Err.Clear
                MsgBox "Nieudany zapis do zakładki '" & rgZakladka & "'" & vbLf & _
                       "w dokumencie '" & rgNazwyZakladek(1).Offset(i, 1) & " " & _
                       rgNazwyZakladek(1).Offset(i, 2) & "'." & vbLf & _
                       "Ale jedziemy dalej.", vbExclamation
            End If
        Next rgZakladka

        strNazwaPliku = strSciezkaZapisu & _
                        ReplaceIllegalCharacters(rgNazwyZakladek(1).Offset(i, 1), "_") & " " & _
                        ReplaceIllegalCharacters(rgNazwyZakladek(1).Offset(i, 2), "_")

        wdDoc.SaveAs Filename:=strNazwaPliku, FileFormat:=wdFormatXMLDocument
        wdDoc.Close SaveChanges:=False

        If Err.Number <> 0 Then
            Err.Clear
            If MsgBox("Nieudany zapis dokumentu" & vbLf & _
                      "'" & rgNazwyZakladek(1).Offset(i, 1) & " " & _
                      rgNazwyZakladek(1).Offset(i, 2) & "'." & vbLf & _
                      "Czy chcesz przerwać dalsze działanie makra?", _
                      vbExclamation + vbYesNo + vbDefaultButton1) = vbYes Then
                GoTo EndProc
            End If
        End If
    Loop


EndProc:
    If Not wksNew Is Nothing Then
      Application.DisplayAlerts = False
      wksNew.Delete
      Application.DisplayAlerts = True
      wksActv.Select
    End If

    If Not blnCzyWordOtwarty Then
        wdApp.Quit
    End If

    Set wdDoc = Nothing
    Set wdApp = Nothing
End Sub

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 383240 Skopiuj do schowka
 
 
Twinkle 
Starszy Forumowicz


Posty: 32
Wysłany: 06-03-2020, 11:21   

W sumie racja, najprostsze rozwiązania są czasami najlepsze.. za bardzo zacząłem kombinować, a to zupełnie wystarcza. Dzięki :)
ID posta: 383245 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe