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: 64423 Skopiuj do schowka Pobieranie danych z pliku Word do Excel
Autor Wiadomość
Marti 
ExcelGaduła 500+



Pomógł: 98 razy
Posty: 931
Wysłany: 13-03-2019, 18:06   Pobieranie danych z pliku Word do Excel

Witam.
Dużo rzeczy już pisałem w VBA w czasie ostatnich lat, ale danych z pliku Word jeszcze nie obrabiałem. Przyszło mi się zmierzyć z tym tematem.

W pewnej mojej aplikacji sieciowej, ludzie z całej Polski wprowadzają nowe sprawy oraz dopinają do nich przeróżne załączniki, w tym pliki Word, xls, pdfy i inne. Pliki mają różne nazwy. Niektóre pliki Word zawierają proste tabele na 2 kolumny i kilkanaście wierszy, co z mojego punktu widzenia jest najbardziej istotne w późniejszej automatyzacji.
Po otwarciu przykładowej sprawy, najpierw zapisuję sobie szybko te załączniki do pustego katalogu Pobrane (C:\Users\Marti\Downloads). W Excelu chciałbym teraz napisać makro, które w pętli sprawdzi mi te załączniki, tzn otworzy każdego Worda i sprawdzi czy tam jest jakaś tabela.
Jeśli jest tabela i w pierwszym wierszu pierwszej kolumny jest wpis 'ID zgłoszenia' oraz
w 4 wierszu 2 kolumny jest wpis 'Klient kluczowy' to:
- całą tabelę należy skopiować do arkusza Excel o nazwie 'roboczy' a plik Word zamknąć i zakończyć pętlę ze sprawdzaniem.

Będę wdzięczny za okazaną pomoc w tym temacie.

Kod:
Sub pobierz_tabele_word()
Dim katalog_zalacznikow As String
Dim zalacznik As String

katalog_zalacznikow = "C:\Users\" & Range("login").Value & "\Downloads\"
       
zalacznik = Dir(katalog_zalacznikow, 7)
   
    Do While zalacznik <> ""
        If Right$(zalacznik, 4) = ".doc" Or Right$(zalacznik, 5) = ".docx" Then
       
        'sprawdzenie czy jest tabela
        Else
        End If
   
    zalacznik = Dir
    Loop
       
End Sub
_________________
Najlepszym dowodem na to, że w kosmosie istnieje inteligencja, jest to, że się z nami nie kontaktują.
ID posta: 364150 Skopiuj do schowka
 
 
Marti 
ExcelGaduła 500+



Pomógł: 98 razy
Posty: 931
Wysłany: 13-03-2019, 20:04   

Żeby mnie tu zaraz nie ochrzaniono, że nie nie przeszukiwałem naszego forum albo innych źródeł by OShon ;-)
zmontowałem taki kod kopiujący tabelę nr 1 (o ile jest) do arkusza roboczy.

Kod:
Sub import_tabeli_word()
Dim WordApp As Object
Set WordApp = CreateObject("Word.Application")

WordApp.Visible = False
WordApp.Documents.Open FileName:=zalacznik_word
If WordApp.ActiveDocument.Tables.Count < 1 Then GoTo koniec

WordApp.ActiveDocument.Tables(1).Range.Copy
Sheets("roboczy").Select
Range("A1").Select
ActiveSheet.Paste

koniec:
WordApp.ActiveWindow.Close
Set WordApp = Nothing

End Sub


No i działa, bo kopiuje całą znalezioną tabelę. Jak zweryfikować dane z takiej tabeli jeszcze przed kopiowaniem? Jak odczytać wartość z 1 kolumny 1 wiersza?
_________________
Najlepszym dowodem na to, że w kosmosie istnieje inteligencja, jest to, że się z nami nie kontaktują.
ID posta: 364162 Skopiuj do schowka
 
 
Marti 
ExcelGaduła 500+



Pomógł: 98 razy
Posty: 931
Wysłany: 13-03-2019, 20:56   

Mam teraz coś takiego

Kod:
If WordApp.ActiveDocument.Tables(1).Cell(1, 1) = "ID zgłoszenia" And WordApp.ActiveDocument.Tables(1).Cell(4, 1) = "Klient kluczowy" Then ...


Ponieważ każda pozycja z tabeli Word kończy się znakiem Chr(7) oraz Chr(13), muszę się ich najpierw pozbywać jeszcze przed sprawdzeniem co w nich się znajduje.
_________________
Najlepszym dowodem na to, że w kosmosie istnieje inteligencja, jest to, że się z nami nie kontaktują.
Ostatnio zmieniony przez Marti 13-03-2019, 21:24, w całości zmieniany 1 raz  
ID posta: 364166 Skopiuj do schowka
 
 
ąćęłńóś
ExcelSpec


Pomógł: 185 razy
Posty: 838
Wysłany: 13-03-2019, 21:20   

Kopiujesz bowiem zawartość tekstową ze znacznikiem końca komórki tabeli .. trzeba to przyciąć jakimś left, right, mid, itd., możesz też spróbować w kodzie 'Application.Clean(tekst)'
ID posta: 364168 Skopiuj do schowka
 
 
Marti 
ExcelGaduła 500+



Pomógł: 98 razy
Posty: 931
Wysłany: 13-03-2019, 21:39   

Kod:
if Replace(Replace(WordApp.ActiveDocument.Tables(1).Cell(1, 1), Chr(7), ""), Chr(13), "") = "ID zgłoszenia" ...


i teraz jest OK ;-)

Natomiast po tym fragmencie kodu:
Kod:
WordApp.ActiveWindow.Close


wyskakuje mi błąd jak w załączniku :-?

Word error.JPG
Plik ściągnięto 1 raz(y) 24.61 KB

_________________
Najlepszym dowodem na to, że w kosmosie istnieje inteligencja, jest to, że się z nami nie kontaktują.
  
ID posta: 364170 Skopiuj do schowka
 
 
ąćęłńóś
ExcelSpec


Pomógł: 185 razy
Posty: 838
Wysłany: 14-03-2019, 01:01   

Marti napisał/a:
Natomiast po tym fragmencie kodu:

WordApp.ActiveWindow.Close

wyskakuje mi błąd jak w załączniku

Marti napisał/a:
WordApp.Visible = False

:-> ... Jeśli zostało jak miałeś na początku, to nie dziw się ...

Wydaje się, że można by to np. w ten sposób ugryźć:
Kod:
Option Explicit

Const id_zgl$ = "ID zgłoszenia"
Const kli_klu$ = "Klient kluczowy"
Const arkusz$ = "Roboczy"
Const wdDoNotSaveChanges As Byte = 0

Sub chodzmy_do_WORDa()
    Dim dostep$, docdok$
   
    dostep = ThisWorkbook.Path & "\" '"C:\Users\" & Range("login").Value & "\Downloads\"
    docdok = Dir(dostep & "*.doc", vbNormal)
   
    Do Until docdok = ""
        Call W_ojewodzki_O_srodek_R_uchu_D_rogowego(dostep, docdok)
        docdok = Dir()
    Loop
End Sub

Sub W_ojewodzki_O_srodek_R_uchu_D_rogowego(dostep$, docdok$)
    Dim appExl As Object: Set appExl = ThisWorkbook
    Dim xlsSht As Object: Set xlsSht = appExl.Sheets(arkusz)
    Dim appWrd As Object: Set appWrd = CreateObject("Word.Application")
    Dim docWrd As Object: Set docWrd = appWrd.Documents.Open(Filename:=dostep & docdok, ReadOnly:=True)
    Dim docRng As Object: Set docRng = docWrd.Range
   
    'appWrd.Visible = True
   
    If docRng.Tables.Count = 0 Then GoTo koniec
    Dim wrs%: wrs = docRng.Tables(1).Rows.Count
    If wrs < 4 Then GoTo koniec
    Dim kol%: kol = docRng.Tables(1).Columns.Count
    If kol < 2 Then GoTo koniec
    Dim tabwrd As Object: Set tabwrd = docRng.Tables(1)
   
    Dim kom1$: kom1 = tabwrd.Cell(1, 1).Range.Text
    kom1 = Left(kom1, Len(kom1) - 2)
    Dim kom2$: kom2 = tabwrd.Cell(4, 2).Range.Text
    kom2 = Left(kom2, Len(kom2) - 2)
   
    If kom1 = id_zgl And kom2 = kli_klu Then
        'MsgBox kom1 & " ; " & kom2
        Dim tbl(): ReDim tbl(1 To wrs, 1 To kol)
        Dim tabCell, k%, w%: w = 1
       
        For Each tabCell In tabwrd.Range.Cells
            k = k + 1: If k > 2 Then w = w + 1: k = 1
            tbl(w, k) = Left(tabCell.Range.Text, Len(tabCell.Range.Text) - 2)
        Next
       
        xlsSht.Range("A1").Resize(wrs, kol).Value = tbl
       
        Erase tbl
    End If

koniec:
    Set tabwrd = Nothing
    Set docRng = Nothing
    docWrd.Close SaveChanges:=wdDoNotSaveChanges
    Set docWrd = Nothing
    appWrd.Quit
    Set appWrd = Nothing
    Set xlsSht = Nothing
    Set appExl = Nothing
End Sub

Trochę rozwlekle, ale u mnie działa (na takiej batelce jak w załączniku).

Batelka.jpg
Plik ściągnięto 1 raz(y) 17.16 KB

ID posta: 364178 Skopiuj do schowka
 
 
Marti 
ExcelGaduła 500+



Pomógł: 98 razy
Posty: 931
Wysłany: 14-03-2019, 09:29   

Jak sprawdzić czy Word jest już uruchomiony?
_________________
Najlepszym dowodem na to, że w kosmosie istnieje inteligencja, jest to, że się z nami nie kontaktują.
ID posta: 364198 Skopiuj do schowka
 
 
ąćęłńóś
ExcelSpec


Pomógł: 185 razy
Posty: 838
Wysłany: 14-03-2019, 11:57   

Najprościej to tak, jak w przypadku sprawdzania dodatkowej instancji excela, tylko "obiekt" inny:
Kod:
Option Explicit

Const plik$ = "ID zgłoszenia.doc"

Sub aaa()
    Dim dostep$: dostep = ThisWorkbook.Path & "\" 'Jeśli 'doc' w tym samym katalogu co 'xls'
    Dim appExl As Object: Set appExl = ThisWorkbook
    Dim appWrd As Object, docWrd As Object, docRng As Object
   
    On Error Resume Next
   
    Set appWrd = GetObject(, "Word.Application")
   
    If Err.Number <> 0 Then
        Err.Clear 'Nadmiarowo - 'On Error' robi to samo
        Set appWrd = CreateObject("Word.Application")
    End If
   
    On Error GoTo 0
   
    Set docWrd = appWrd.Documents.Open(Filename:=dostep & plik, ReadOnly:=True)
    Set docRng = docWrd.Range
   
    appWrd.Visible = True
   
    docRng.Select
   
    Set docRng = Nothing
    docWrd.Close SaveChanges:=0 'Const wdDoNotSaveChanges As Byte = 0
    Set docWrd = Nothing
    appWrd.Quit
    Set appWrd = Nothing
    Set appExl = Nothing
End Sub
ID posta: 364212 Skopiuj do schowka
 
 
Marti 
ExcelGaduła 500+



Pomógł: 98 razy
Posty: 931
Wysłany: 14-03-2019, 12:02   

Czy taki kod też jest OK?

Kod:
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")

If WordApp Is Nothing Then
Set WordApp = CreateObject("Word.Application")

Else
End If

On Error GoTo 0



A jak sprawdzić, czy czasami wybrany plik nie jest już otwarty w Wordzie?
_________________
Najlepszym dowodem na to, że w kosmosie istnieje inteligencja, jest to, że się z nami nie kontaktują.
  
ID posta: 364213 Skopiuj do schowka
 
 
ąćęłńóś
ExcelSpec


Pomógł: 185 razy
Posty: 838
Wysłany: 14-03-2019, 12:21   

Marti napisał/a:
Czy taki kod też jest OK

Jeśli działa, a przecież działa to "raczej" tak ... :-> ... tylko podejście do wyłapywania błędu jest inne - Err.Number wyłapuje tu błąd 429, zaś Set WordApp skutkuje brakiem przypisania do obiektu.
  
ID posta: 364215 Skopiuj do schowka
 
 
ąćęłńóś
ExcelSpec


Pomógł: 185 razy
Posty: 838
Wysłany: 14-03-2019, 12:59   

Marti napisał/a:
jak sprawdzić, czy czasami wybrany plik nie jest już otwarty

Zrobiłbym to na przykład tak:
Kod:
    Const plik$ = "ID zgłoszenia.doc"
    dostep = ThisWorkbook.Path & "\"

    On Error Resume Next
   
    Set appWrd = GetObject(, "Word.Application")
   
    If appWrd Is Nothing Then
        Err.Clear
        Set appWrd = CreateObject("Word.Application")
        Set docWrd = appWrd.Documents.Open(Filename:=dostep & plik, ReadOnly:=True)
    Else
        Set docWrd = appWrd.Documents(plik)
       
        If docWrd Is Nothing Then
            Err.Clear
            Set docWrd = appWrd.Documents(1) 'Dla jednego pliku - gdy wiele to już jakaś pętla
            MsgBox "Jakiś inny plik: '" & docWrd.Name & "' jest już otwarty"
            'docWrd.Close SaveChanges:=0 '???
            Set docWrd = appWrd.Documents.Open(Filename:=dostep & plik, ReadOnly:=True)
        Else
            MsgBox "Właściwy plik: '" & docWrd.Name & "' jest już otwarty"
        End If
    End If
   
    On Error GoTo 0
   
    Set docRng = docWrd.Range
    appWrd.Visible = True
    docRng.Select
ID posta: 364217 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