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
14-02-2021, 11:06
Kopiowanie danych z tabeli do worda we wskazane miejsce
Autor Wiadomość
Kisiel 
Świeżak


Wersja: Win Office 365
Posty: 2
Wysłany: 12-02-2021, 21:38   Kopiowanie danych z tabeli do worda we wskazane miejsce

Witam wszystkich.
Mam problem, a raczej zupełnie nie wiem jak się za to zabrać i chciałbym podpytać Was o zdanie. Mam pewien arkusz w którym uzupełniam dane i na jego podstawie generuje sobie plik worda.
Chciałbym do tego jeszcze dorzucić tabelę, której wartości również chciałbym przekopiować do wskazanego miejsca we wspomnianym pliku word'a.
Czy dałoby aby skrypt sprawdzał tę tabelę pod kątem uzupełnionych danych i przerywał kopiowanie w momencie gdy wykryje, że kolejny wiersz jest już pusty ?

Może przesłać pliki aby lepiej to zobrazować ?
Albo jakieś screeny ?

Formularz - zgłoszenie reklamacyjne.rar
W środku 2 pliki
Pobierz Plik ściągnięto 5 raz(y) 37.21 KB

ID posta: 400293 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3091 razy
Posty: 10242
Wysłany: 14-02-2021, 01:39   

Kod:
Sub zlecenie()
    Dim objWord     As Object
    Dim oDoc        As Object
    Dim oRow        As Object
    Dim varrBkMrks  As Variant
    Dim wks         As Worksheet
    Dim lRow        As Long
    Dim i           As Long

    Const strPath   As String = "C:\Users\Hubert\Desktop\Formularz - zgłoszenie reklamacyjne\"
    Const strFullName As String = strPath & "Zgłoszenie reklamacji.docx"

    Const wdAutoFitWindow As Long = 2
    Const wdCellAlignVerticalCenter As Long = 1
    Const wdAlignParagraphCenter As Long = 1

    Set wks = ActiveSheet

    '--------------------
    'tutaj powinieneś sprawdzić, czy WSZYSTKIE istotne pola w arkuszu są wypełnione
    'jeżeli czegoś brak to Exit Sub
    '--------------------

    'znajdź ostatnią niepustą komórkę w zakresie E2:M22
    lRow = GetLastCell(wks.Range("E2:M22"), xlByRows, False).Row

    'najpierw sprawdź, bo może Word już jest uruchomiony
    On Error Resume Next
    Set objWord = GetObject(, "Word.Application")
    On Error GoTo 0

    'jl. nie był, to go uruchom
    If objWord Is Nothing Then
        Set objWord = CreateObject("Word.Application")
    End If

    objWord.Visible = True

    'otwórz dokument jako szablon
    Set oDoc = objWord.Documents.Add(Template:=strFullName, NewTemplate:=True)

    'Zakładki
    varrBkMrks = Split("Miasto|Data1|Kupujacy|Nadlesnictwo|Lesnictwo|Nrwydania|Datawydania|Nrsprzedazy|Datasprzedazy", "|")


    With oDoc
        'wypełnij zakładki
        For i = 0 To UBound(varrBkMrks)
            .Bookmarks(varrBkMrks(i)).Range.Text = wks.Cells(i + 1, "B").Value
        Next i

        'skopiuj "wyliczoną" tabelę
        wks.Range("D1:M" & lRow).Copy

        .Bookmarks("l").Range.Select
        'wklej tabelę do dokumentu
        .Parent.Selection.PasteExcelTable False, False, False    'objWord

        'dopasuj tabelę do strony
        .Tables(1).AutoFitBehavior (wdAutoFitWindow)

        '"lekko" przeformatuj wiersze tabeli
        For Each oRow In .Tables(1).Rows
            If oRow.Index > 1 Then
                oRow.Range.Font.Size = 10
            Else
                oRow.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
                oRow.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter

            End If
        Next oRow

        'zapisz dokument pod określoną nazwą (automatycznie usuń niedozwolone znaki)
        '.SaveAs strPath & ReplaceIllegalCharacters(Range("B6").Value, "_") & ".docx"
    End With
   
    objWord.Activate

    Set objWord = Nothing
    Application.CutCopyMode = False

End Sub



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


Function GetLastCell(InRange As Range, SearchOrder As XlSearchOrder, _
                     Optional ProhibitEmptyFormula As Boolean = False) As Range
    ' By Chip Pearson,  www.cpearson.com
    Dim WS          As Worksheet
    Dim R           As Range
    Dim LastCell    As Range
    Dim LastR       As Range
    Dim LastC       As Range
    Dim SearchRange As Range
    Dim LookIn      As XlFindLookIn
    Dim RR          As Range

    Set WS = InRange.Worksheet

    If ProhibitEmptyFormula = False Then
        LookIn = xlFormulas
    Else
        LookIn = xlValues
    End If

    Select Case SearchOrder
        Case XlSearchOrder.xlByColumns, XlSearchOrder.xlByRows, _
             XlSearchOrder.xlByColumns + XlSearchOrder.xlByRows
            ' OK
        Case Else
            Err.Raise 5
            Exit Function
    End Select

    With WS
        If InRange.Cells.Count = 1 Then
            Set RR = .UsedRange
        Else
            Set RR = InRange
        End If

        Set R = RR(RR.Cells.Count)

        If SearchOrder = xlByColumns Then
            Set LastCell = RR.Find(what:="*", after:=R, LookIn:=LookIn, _
                                   LookAt:=xlPart, SearchOrder:=xlByColumns, _
                                   SearchDirection:=xlPrevious, MatchCase:=False)
        ElseIf SearchOrder = xlByRows Then
            Set LastCell = RR.Find(what:="*", after:=R, LookIn:=LookIn, _
                                   LookAt:=xlPart, SearchOrder:=xlByRows, _
                                   SearchDirection:=xlPrevious, MatchCase:=False)
        ElseIf SearchOrder = xlByColumns + xlByRows Then
            Set LastC = RR.Find(what:="*", after:=R, LookIn:=LookIn, _
                                LookAt:=xlPart, SearchOrder:=xlByColumns, _
                                SearchDirection:=xlPrevious, MatchCase:=False)
            Set LastR = RR.Find(what:="*", after:=R, LookIn:=LookIn, _
                                LookAt:=xlPart, SearchOrder:=xlByRows, _
                                SearchDirection:=xlPrevious, MatchCase:=False)
            Set LastCell = Application.Intersect(LastR.EntireRow, LastC.EntireColumn)
        Else
            Err.Raise 5
            Exit Function
        End If
    End With

    Set GetLastCell = LastCell

End Function
Popracuj jeszcze nad właściwymi odstępami przed/po zakładkach w dokumencie.

Artik
_________________
Persistence is a virtue in the world of programming.
  
ID posta: 400353 Skopiuj do schowka
 
 
Kisiel 
Świeżak


Wersja: Win Office 365
Posty: 2
Wysłany: 14-02-2021, 10:24   

Naprawdę najmocniej dziękuję :)
Muszę jeszcze kilka rzeczy rozbudować ale mam już solidną podstawę - jeszcze raz wielkie dzięki !!!
ID posta: 400358 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