Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Kopiowanie danych z tabeli do worda we wskazane miejsce

Kisiel · Świeżak Wersja: Win Office 365 Posty: 2

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

Artik · Wersja: Win Office 365 **Pomógł:** 3091 razy Posty: 10242

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

Kisiel · Świeżak Wersja: Win Office 365 Posty: 2

Naprawdę najmocniej dziękuję :)
Muszę jeszcze kilka rzeczy rozbudować ale mam już solidną podstawę - jeszcze raz wielkie dzięki !!!