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
ID tematu: 68323 Skopiuj do schowka Zapis do Word - w określonym miejscu dokumentu
Autor Wiadomość
slavio 
Exceloholic


Pomógł: 2 razy
Posty: 138
Wysłany: 09-06-2020, 21:57   Zapis do Word - w określonym miejscu dokumentu

Hej
Mam taki kod, który zapisuje mi dane w nowym dokumencie Word tabelkę z Excela i na końcu zapisuje w tej samej lokalizacji z taką samą nazwą - tylko jako word.

Jak zmusić Excela, aby zrobił to samo, w pliku istniejącym (wskazanym), ale w określonym punkcie dokumentu.... np pod puntem 4 lub 5 lub pod jakimś określonym sformułowaniem.

Kod:

Private Sub ExcelRangeToWord_pionowo()

'PURPOSE: Copy/Paste An Excel Table Into a New Word Document
'NOTE: Must have Word Object Library Active in Order to Run _
  (VBE > Tools > References > Microsoft Word 12.0 Object Library)
'SOURCE: www.TheSpreadsheetGuru.com

Dim tbl As Range
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
Dim SCIEZKA As String
Dim NazwaPliku As String
Dim NameOfWorkbook As String


'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False

Dim lastrow As Long
    Worksheets("oferta").Select
    lastrow = Worksheets("oferta").Range("f10000").End(xlUp).Row
   
   
SCIEZKA = ThisWorkbook.path
NazwaPliku = ThisWorkbook.Name
NameOfWorkbook = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1))

'Copy Range from Excel
  Set tbl = Worksheets("oferta").Range("A1:h" & lastrow + 5)

'Create an Instance of MS Word
  On Error Resume Next
   
    'Is MS Word already opened?
      Set WordApp = GetObject(Class:="Word.Application")
   
    'Clear the error between errors
      Err.Clear

    'If MS Word is not already open then open MS Word
      If WordApp Is Nothing Then Set WordApp = CreateObject(Class:="Word.Application")
   
    'Handle if the Word Application is not found
      If Err.Number = 429 Then
        MsgBox "Microsoft Word nie został znaleziony, lub pojawił się błąd 429"
        GoTo EndRoutine
      End If

  On Error GoTo 0
 
'Make MS Word Visible and Active
  WordApp.Visible = True
  WordApp.Activate
   
'Create a New Document
  Set myDoc = WordApp.Documents.Add
 
'Copy Excel Table Range
  tbl.Copy

'Paste Table into MS Word
  myDoc.Paragraphs(1).Range.PasteExcelTable _
    LinkedToExcel:=False, _
    WordFormatting:=False, _
    RTF:=False
   
   
'Autofit Table so it fits inside Word Document
  Set WordTable = myDoc.Tables(1)
  WordTable.AutoFitBehavior (wdAutoFitWindow)
 
 
myDoc.SaveAs2 (SCIEZKA & "\" & NameOfWorkbook & "_oferta dla Klienta_" & Format(Date, "dd.mm.yyyy") & "_" & Format(Time, "hh_mm") & "_wydruk pionowy" & ".docx")
WordApp.Quit
 
EndRoutine:

End Sub



Slavio
ID posta: 388549 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Wersja: Win Office 2013
Pomógł: 718 razy
Posty: 3871
Wysłany: 09-06-2020, 22:08   

Na "dzień dobry":
Cytat:
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False

Dim lastrow As Long
Worksheets("oferta").Select
lastrow = Worksheets("oferta").Range("f10000").End(xlUp).Row
Sprzeczność.
.
_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
Chcesz precyzyjną odpowiedź - zadaj precyzyjne pytanie.
ID posta: 388550 Skopiuj do schowka
 
 
slavio 
Exceloholic


Pomógł: 2 razy
Posty: 138
Wysłany: 09-06-2020, 23:10   

hej, późno więc nie spodziewałem się super dużo odpowiedzi.....

Jakoś sobie poradziłem:


Kod:

Private Sub ExcelRangeToWord_pionowo()

'PURPOSE: Copy/Paste An Excel Table Into a New Word Document
'NOTE: Must have Word Object Library Active in Order to Run _
  (VBE > Tools > References > Microsoft Word 12.0 Object Library)
'SOURCE: www.TheSpreadsheetGuru.com

Dim tbl As Range
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
Dim SCIEZKA As String
Dim NazwaPliku As String
Dim NameOfWorkbook As String


'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False

Dim lastrow As Long
    Worksheets("oferta").Select
    lastrow = Worksheets("oferta").Range("f10000").End(xlUp).Row
   
   
SCIEZKA = ThisWorkbook.path
NazwaPliku = ThisWorkbook.Name
NameOfWorkbook = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1))

'Copy Range from Excel
  Set tbl = Worksheets("oferta").Range("A1:h" & lastrow + 5)

'Create an Instance of MS Word
  On Error Resume Next
   
    'Is MS Word already opened?
      Set WordApp = GetObject(Class:="Word.Application")
   
    'Clear the error between errors
      Err.Clear

    'If MS Word is not already open then open MS Word
      If WordApp Is Nothing Then Set WordApp = CreateObject(Class:="Word.Application")
   
    'Handle if the Word Application is not found
      If Err.Number = 429 Then
        MsgBox "Microsoft Word nie został znaleziony, lub pojawił się błąd 429"
        GoTo EndRoutine
      End If

  On Error GoTo 0
 
'Make MS Word Visible and Active
  WordApp.Visible = True
  WordApp.Activate
   
'Create a New Document to na chwilę wyłączamy
  'Set myDoc = WordApp.Documents.Add
 
Set myDoc = GetObject(" TU Ścieżka do pliku, z którego korzystam, do niego wklejam tabelę i zapisuję pod nową nazwą ".docx") 'jesli chcemy kozystac z szablonu

'Copy Excel Table Range
  tbl.Copy

   
    Dim wordDoc As Object
    Dim searchRange As Object
    Dim p As Long
   
    'Set wordDoc = WordApp.Documents.Open(Filename)
    Set searchRange = myDoc.Range

    With searchRange.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "kosztorys"
        .Wrap = 0                     '=wdFindStop
        While .Execute(FindText:="kosztorys", Forward:=True)
            If .Found Then
                p = GetParNum(myDoc, .Parent)
            End If
        Wend
    End With

    myDoc.Paragraphs(p + 2).Range.Select
   myDoc.Paragraphs(p + 2).Range.PasteExcelTable _
    LinkedToExcel:=False, _
    WordFormatting:=False, _
    RTF:=False
   
'Autofit Table so it fits inside Word Document
  Set WordTable = myDoc.Tables(1)
  WordTable.AutoFitBehavior (wdAutoFitWindow)
 
 
myDoc.SaveAs2 (SCIEZKA & "\" & NameOfWorkbook & "_oferta dla Klienta_" & Format(Date, "dd.mm.yyyy") & "_" & Format(Time, "hh_mm") & "_wydruk pionowy" & ".docx")
WordApp.Quit
 
EndRoutine:

End Sub



Kod:

Function GetParNum(ByRef doc As Object, ByRef r As Object) As Integer
    '--- based on http://www.vbaexpress.com/kb/getarticle.php?kb_id=59
    Dim rParagraphs As Object
    Dim CurPos As Long

    r.Select
    CurPos = doc.Bookmarks("\startOfSel").START
    Set rParagraphs = doc.Range(START:=0, End:=CurPos)
    GetParNum = rParagraphs.Paragraphs.Count
End Function



Slavio
ID posta: 388551 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