Kapalı PDF Dosyasından Dolu Hücrelerdeki Verileri Almak

[ormann]

Haluk bey birde yarın iş yerinde denerim. Bende PDF okuyucu adobe reader değil ondan olabilir mi ki ?

 

[Haluk]

PDF'ler için varsayılan programın Adobe Reader olup, olmaması önemli değil .... Hemen her bilgisayarda iyi, kötü bir Adobe Reader versiyonu vardır zaten.

Ayakta sağlam duran, çalışan bir bilgisayar ve Ofis yazılımı olsun yeter....


.

 

[ormann]

Haluk bey günaydın. Dosyayı iş yerimde denedim. Kod gayet güzel çalışıyor.Sizden ricam veri alırken aşağıdaki şartlarda alabilir mi?.
1-Veri alınacak dosyadan sadece 2 ve 3. sutunlar alınacak.
2-Alınan veriler Dikili Giriş sayfasında ağaç cinsi (2.Sütun) F20:F sütununa; 1.30 Çapı (3.Sutun) G20:G sütununa alaınacak
3-Ağaç Cinsi her PDF dosyasında farklı olduğundan değişkenlik gösteriyor. PDF dosyasında hangi ağaç cinsi varsa onu alacak.

 

[ormann]

Haluk bey birde 23. mesajıma ilave olarak PDF dosyası fazla olduğundan dosya aç işlemi ile veri alacağımız PDF dosyasını seçebilir miyiz. Ayrıca ana dosyam devamlı bu klasörün içerisinde olma zorun da mı. ?

 

[Haluk]

Günaydın;

Excel dosyasının çalışma mantığı şu şekildedir...... Klasörün içindeki tüm PDF'lerin içindeki "Ağaç Cinsi" eğer "Kavak" ise, verileri Excel'de sayfaya alt alta yazar.

Farklı ağaç cinsleriniz varsa, burada belirtin .... kodda ona göre düzenleme yaparım. Eğer tüm PDF'lerin aktarılmasını istemiyorsanız, onu da belirtin.

Daha önce dediğim gibi, bu çalışma PDF dosyalarındaki tabloların tümünü aktarır. Bunların içinden işinize yarayan verileri siz kendiniz VBA ile ayıklayacaksınız.

İlave olarak; dosya yükleyip, indirmek için "Altın Üye" olmanızda fayda var. Hazırlanan dosyaları hem foruma hem de başka bir sunucuya yüklemeye artık vakit kaybı gibi geliyor bana....


.

 

[ormann]

Haluk bey PDF dosyasındaki verileri excel sayfasında B2:I hücre aralığına alabilir mi?. Veriler alındıktan sonra aynı makro E2:I hücrelerindeki verileri silebilir mi?

 

[Haluk]

Sadece "Ağaç Cinsi" ve "H=1,30 mt Çapı" sütunlarının mı aktarılmasını istiyorsunuz?

.

 

[ormann]

İlk Üç sutun akarılacak. ( "Dip Kütük No" ,"Ağaç Cinsi" ve "H=1,30 mt Çapı" ) . Excel sayfasında B2 hücre aralığına aktarılacak.Haluk bey klsörün içerisinde örneğin 15 adet pdf var ben seçmiş olduğum dosyayı alma durumu olmaz mı?

 

[ormann]

Haluk bey kodları düzenledim. Tam istediğim aralıktaki verileri alıyor.Tek istediğim klasördeki verilerin tamamını değilde sadece istediğim PDF dosyalarındaki verileri alsa istediğim olacak.

Sub Test89()
'   Haluk - 18/05/2020
'   sa4truss@gmail.com
'
    Dim FSO As Object, dosya As Variant, pdfDoc As PDFDocument, pages As PDFPageCollection
    Dim t As Byte
    Dim RegExp As Object, RetVal As Variant
    Dim txtPDF As String
    Dim NoA As Integer, i As Integer
    
    Range("B2:D" & Rows.Count) = ""

    Set FSO = CreateObject("Scripting.FileSystemObject")
    folderpath = ThisWorkbook.Path
    
    Set RegExp = CreateObject("VBScript.RegExp")
    
    RegExp.IgnoreCase = True
    RegExp.MultiLine = True
    RegExp.Global = True
    RegExp.Pattern = "(\d{1,4})\s(Kavak)\s(.+?)\s(.+?)\s(.+?)\s(.+?)\s(.+?)\s(.+?)\s(.+?)"
    
    For Each dosya In FSO.GetFolder(folderpath).Files
        If LCase(FSO.GetExtensionName(dosya)) = "pdf" Then
            NoA = Range("B" & Rows.Count).End(xlUp).Row + 1
            Set pdfDoc = New PDFDocument
            Set pages = pdfDoc.OpenPdf(dosya)
            
            For t = 0 To pages.Count - 1
                txtPDF = WorksheetFunction.Trim(pages(t).GetText) & vbCrLf
                i = Range("B" & Rows.Count).End(xlUp).Row
                If RegExp.Test(txtPDF) Then
                    For Each RetVal In RegExp.Execute(txtPDF)
                        i = i + 1
                        Range("B" & i) = RetVal.Submatches(0) + 0
                        Range("C" & i) = RetVal.Submatches(1)
                        Range("D" & i) = RetVal.Submatches(2) + 0
                      
                    Next
                End If
            Next
        End If
    Next
    
    Set RegExp = Nothing
    pdfDoc.ClosePdf
    Set pages = Nothing
    Set pdfDoc = Nothing
    Set FSO = Nothing
End Sub

 

[Haluk]

Sub Test90()
'   Haluk - 20/05/2020
'   sa4truss@gmail.com
'
    Dim pdfDoc As PDFDocument, pages As PDFPageCollection
    Dim t As Byte
    Dim RegExp As Object, RetVal As Variant
    Dim txtPDF As String
    Dim NoA As Integer, i As Integer
   
    Range("B2:D" & Rows.Count) = ""

    myFile = Application.GetOpenFilename("PDF dosyaları, *.pdf")
   
    If myFile = False Then Exit Sub

    Set RegExp = CreateObject("VBScript.RegExp")
   
    RegExp.IgnoreCase = True
    RegExp.MultiLine = True
    RegExp.Global = True
    RegExp.Pattern = "(\d{1,4})\s(Kavak)\s(.+?)\s(.+?)\s(.+?)\s(.+?)\s(.+?)\s(.+?)\s(.+?)"
   
    NoA = Range("B" & Rows.Count).End(xlUp).Row + 1
    Set pdfDoc = New PDFDocument
    Set pages = pdfDoc.OpenPdf(myFile)
   
    i = Range("B" & Rows.Count).End(xlUp).Row
   
    For t = 0 To pages.Count - 1
        txtPDF = WorksheetFunction.Trim(pages(t).GetText) & vbCrLf
        If RegExp.Test(txtPDF) Then
            For Each RetVal In RegExp.Execute(txtPDF)
                i = i + 1
                Range("B" & i) = RetVal.Submatches(0) + 0
                Range("C" & i) = RetVal.Submatches(1)
                Range("D" & i) = RetVal.Submatches(2) + 0
            Next
        End If
    Next

    Set RegExp = Nothing
    pdfDoc.ClosePdf
    Set pages = Nothing
    Set pdfDoc = Nothing
End Sub

.

 

[ormann]

Haluk hocam son olarak verileri B20 hücre aralığına almak istiyorum. Şu satırı değiştirdim fakat olmuyor.

 Range("B20:D" & Rows.Count) = ""

 

[Haluk]

Aşağıdaki satırı;

    i = Range("B" & Rows.Count).End(xlUp).Row

Bununla değiştirin;

    i = 19

.

 

[ormann]

Haluk bey çok teşekkür ederim. PdfToText klasörünü devamlı bulundurmak zorundamıyız. Bu klasörü excelin içerisine almanın bir yolu yok mu?

 

[Haluk]

Var ama, başka türlü sıkıntılar çıkabilir. Sizin için mahsuru yoksa o şekilde kullanın ...

.

 

[ormann]

Haluk bey zahmet olmayacaksa .Sizi uğraştırmayacaksa yapabilir misiniz ?

 

[Haluk]

DLL dosyalarını Excel dosyasının içine gömdükten sonra bilgisayarda bir yere çıkartıp, oradan kullanabiliriz ama; o zaman dosya boyutu yaklaşık 2 MB civarında büyür ve belki bazı başka sorunlara yol açabilir.

Siz eğer kullandığımız "PDFToText" klasörünün, Excel dosyasının olduğu yerde bulunmasından rahatsız iseniz ( gerçi niye rahatsız oluyorsunuz, anlamadım ama .... neyse) o zaman şöyle yapalım ....

Söz konusu "PDFToText" klasörünü, Excel dosyasının olduğu yerden sildikten sonra, bilgisayarınızda "My Documents - Belgelerim" klasörünün içine yerleştirin ve daha sonra ekli Excel dosyasını kullanın.


Dosyanın harici linki aşağıdadır (bir süre sonra link silinecektir):

Test3.xlsm

drive.google.com

.

 

[Haluk]

Haluk bey zahmet olmayacaksa .Sizi uğraştırmayacaksa yapabilir misiniz ?

Dosyayı indirip, denediniz mi?

.

 

[ormann]

Haluk bey çok teşekkür ederim.Gayet güzel çalıştı.Ellerinize sağlik

 

[bmutlu966]

Arkadaşlar ekli dosya faydalı olabilir. PDF dosyasını önce Word'e sonra Excel'e aktarır. Çalışması için

Visual Basic penceresinden
Tools\References\Mikrosoft Scripting Runtime aktif olmasi gerekiyor.