Çözüldü PDF'ten Veri Almak

[lon_tokyo]

Merhabalar herkese,

Asagida kod araciligiyla (internet uzerinden buldugum) belirtilen klasor icerisinde ki pdf dosyalarini kopyalayip, her pdf icin ayri sayfa actirip datalari ilgili sayfaya kaydetmek istiyorum, kod hem calismakta hemde calismamakta nasil yani derseniz, renkli olarak isaretledigim kisim ayni sayfa mevcut ise silmekte bu nedenle, actigi sayfayi otomatik olarak sildiginden, kod sadece son sayfanin verisini dosyama aktarabilmekte, denedim ancak basarli olamadim, siz ustalarimdan konu hakkinda yardim alabilir miyim ? yardiminiz icin simdiden tesekkur ederim.

On Error Resume Next
Set wsOutp = Sheets(strFile)

On Error GoTo 0
If Not wsOutp Is Nothing Then
wsOutp.Delete
End If

Option Explicit

Sub LoopThroughFiles()
    Dim strFile As String, strPath As String
    Dim colFiles As New Collection
    Dim i As Integer
    Dim rLog As Range, rOut As Range
    Dim wsLog As Worksheet, wsOutp As Worksheet
    Dim Activesheet As Worksheet
   
   
    strPath = "C:\Users\PLHUTEK\Desktop\D\" 'pdf dosyalarinin yer aldigi klasor
    strFile = Dir(strPath)
    ' Make a log sheet
    On Error Resume Next
    Set wsLog = Sheets("PdfProcessLog")
    On Error GoTo 0
    If wsLog Is Nothing Then
        Set wsLog = ThisWorkbook.Sheets.Add(before:=Sheets(1))
        wsLog.Name = "PdfProcessLog"
    End If
    Set rLog = wsLog.Range("A1")
    rLog.CurrentRegion.ClearContents
    rLog.Value = "PDF files copied to sheets"
   
    ' load all the files in a Collection
    While strFile <> ""
        If StrComp(Right(strFile, 3), "pdf", vbTextCompare) = 0 Then
            colFiles.Add strFile
        End If
        strFile = Dir
    Wend
   
    Application.DisplayAlerts = False
   
    'Loop through the pdf's stored in the collection
    For i = 1 To colFiles.Count
        'List filenames in Column A of the log sheet
        rLog.Offset(i, 0).Value = colFiles(i)
        strFile = Left(colFiles(i), Len(colFiles(i)) - 4)
       
      ' Delete sheet with filename if exists
        On Error Resume Next
        Set wsOutp = Sheets(strFile)
       
        On Error GoTo 0
        If Not wsOutp Is Nothing Then
            wsOutp.Delete
        End If
       
       
        ' (Re)Create the worksheet, give it the file name
        Set wsOutp = ThisWorkbook.Sheets.Add(after:=wsLog)
        wsOutp.Name = strFile
       
        ' Now open the file, and copy contents
        OpenClosePDF colFiles(i), strPath
        CopyStep wsOutp
    Next i
   
    Application.DisplayAlerts = True

End Sub
Sub OpenClosePDF(ByVal sAdobeFile As String, ByVal sPath As String)

    Dim sAdobeApp As String
    Dim vStartAdobe As Variant
   

    sAdobeApp = "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe"
    vStartAdobe = Shell("" & sAdobeApp & " " & sPath & sAdobeFile & "", 1)
    Application.Wait (Now + TimeValue("0:00:03"))

End Sub


Private Sub CopyStep(wsOutp As Worksheet)

    ' select all & copy
    SendKeys "^a", True
    SendKeys "^c", True
     Application.Wait (Now + TimeValue("0:00:05"))
   ' Paste into the sheet from cell A1
 
AppActivate Title:=ThisWorkbook.Application.Caption
Activesheet.[A1].Select
SendKeys "^v"

Dim sKillAdobe As String

sKillAdobe = "TASKKILL /F /IM AcroRd32.exe"
Shell sKillAdobe, vbHide

End Sub

 

[lon_tokyo]

Selamlar,

Sorunu cozmeyi basardim sanirsam, ileride birilerine yarari olabilir diye kodlari paylasmak istiyorum,

Makro bulundugu klasorde ki tum PDF uzantili dosyalarinda ki datalari alarak, herbirine ilgili excel dosyasi icerisinde ayri sayfalar acip kayit yapmaktadir, buyrun kodlar.

Sub KirmizidanAL()
    Dim strFile As String, strPath As String
    Dim colFiles As New Collection
    Dim i As Integer
    Dim c As Range
    Dim sayfadi As String
    Dim uygulama As String
    Dim vStartAdobe As Variant
    Dim rLog As Range, rOut As Range
    Dim wsLog As Worksheet, wsOutp As Worksheet
    Dim Activesheet As Worksheet
    Dim yolum As String
    Dim Sheet As Worksheet
    Dim sKillAdobe As String
    Dim DataObj As MSForms.DataObject
    Set DataObj = New MSForms.DataObject
    
    yolum = Application.ActiveWorkbook.Path
    Application.CutCopyMode = False
    
    strPath = yolum & "\"
    strFile = Dir(strPath)
    ' Make a log sheet
    On Error Resume Next
    Set wsLog = Sheets("TXT-ProcessLog")
    On Error GoTo 0
    If wsLog Is Nothing Then
        Set wsLog = ThisWorkbook.Sheets.Add(before:=Sheets(1))
        wsLog.Name = "TXT-ProcessLog"
    End If
    Set rLog = wsLog.Range("A1")

    While strFile <> ""
        If StrComp(Right(strFile, 3), "pdf", vbTextCompare) = 0 Then
            colFiles.Add strFile
        End If
        strFile = Dir
    Wend
    

 
 
  'klasorde ki dosyalarin ismini listele
    For i = 1 To colFiles.Count
        rLog.Offset(i, 0).Value = colFiles(i)
        strFile = Left(colFiles(i), Len(colFiles(i)) - 4)
    Next i


For Each c In Range("A:A")
If c <> "" Then
    
        'listede ki isme gore sayfa olustur
        Set wsOutp = ThisWorkbook.Sheets.Add(after:=wsLog)
        On Error Resume Next
        wsOutp.Name = c
 
    'dosyayi ac ve icinde kileri kopyala gardas
    uygulama = "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe"
    vStartAdobe = Shell("" & uygulama & " " & strPath & c & "", 1)
Application.Wait (Now + TimeValue("0:00:02"))
    SendKeys "^a", True
    SendKeys "^c", True
Application.Wait (Now + TimeValue("0:00:10"))

sKillAdobe = "TASKKILL /F /IM AcroRd32.exe"
Shell sKillAdobe

AppActivate Title:=ThisWorkbook.Application.Caption
Application.Wait (Now + TimeValue("0:00:01"))

With Activesheet
DataObj.GetFromClipboard
strPaste = DataObj.GetText(1)

[A1].Select
wsOutp.Paste
Application.Wait (Now + TimeValue("0:00:05"))


End With
End If
Next c

Application.DisplayAlerts = True
End Sub

 

[schlecht]

strPath = yolum & "\"

buraya kendi dosya yolumu yazdım fakat

strFile = Dir(strPath) burada hata verdi. Örnek dosya yüklemeniz mümkün mü?

 

[lon_tokyo]

Merhabalar

Ornek dosya ekte ki gibidir.
"C:\Attachments" kismini kendinize gore yorumlamayabilirsiniz.
Ayrica ben bekleme sureleri koydum verileri alirken veri buyuklugune gore benim 30 saniye kullaniyorum, dosya da 3 saniyeyi kendinize gore azaltabilirsiniz.
Iyi Calismalar

 

[schlecht]

Teşekkürler. İyi Çalışmalar.

 

[mustilem23]

Merhaba
lon_tokyo ;

Benim de bu şekilde bir makroya ihtiyacım mevcut dosyanızı indiridim lakin ,dosya açılır iken hata verdi diye uyarı veriyor .
Lakin excel içinde sayfaları ve konumunun olduğu sayfaları oluşturuyor .
Benim pc 64 bit ondan kaynaklanıyor olabilir mi ? birde pdf görüntüleyicim adobe acrotat reader dc .

yardımcı olabilir misiniz teşekkürler.

 

[u.L.a.s]

Merhaba

bende bu script "Dim DataObj As MSForms.DataObject" satırında compile error hatası verdi.

neden olabilir.

ayrıca şunu sormak istiyorum.

Bu script pdf dosya içerisinde ne varsa onu birebir excele hücre hücre mi aktarıyor.

 

[lon_tokyo]

Merhabalar

Aldiginiz hatanin reference lar kisminda Microsoft Forms'un olmamasindan kaynaklandigini dusunuyorum,
Rica etsem, bir kontrol edermisiniz .

Ikinci sorunuz icin ise PDF inizin gorunumu ile alakali olarak herseyi kopaylayabilir de kopyalamayada bilir,
PDF inizi birden fazla sayfadan olusuyorsa, scroll down ile asagi inebiliryosaniz tum sayfalari kopyalabilir, diger turlu kopayalam gorunen sayfa ile sinirlidir.

Merhaba

bende bu script "Dim DataObj As MSForms.DataObject" satırında compile error hatası verdi.

neden olabilir.

ayrıca şunu sormak istiyorum.

Bu script pdf dosya içerisinde ne varsa onu birebir excele hücre hücre mi aktarıyor.

 

[lon_tokyo]

Merhabalar,

Sorunuzu tam anlayamadim, rica etsem ekran goruntusu ekleyebilir misiniz nasil, bir uyari aldiginizi gorebilmek icin.

an kaynaklanıyor olabilir mi ? birde pdf görüntüleyicim adobe acrotat reader dc .

yardımcı olabilir misiniz teşekkü

 

[Tevfik_Kursun]

Merhaba Sayın Ion_tokyo,
Teşekkürler. Ama sayfaların her noktasını okuyamıyor sanırım.
İyi çalışmalar

 

[lon_tokyo]

Merhabalar,
kopyalanmasini istediginiz sayfada kisacasi CTRL+A yapip kopyalama yapmaktadir,
bunun disinda kalan herhangi bir yer oldugunu sanmiyorum, ama olma ihtimali de olabilir.

Adobe den sayfalari nasil goruntulediginizi kontrol ediniz, farenin tekerlegi ile asagi sayfalara inebiliyorsaniz, kopyalamayi yapmasi lazim tabi bu arada kopyalama suresini, pdf boyutune gore arttirip azaltamanizii tavsiye ederim. F8 ile lerleyip asamalari gorebilirsiniz.
Iyi gunler

 

[Tevfik_Kursun]

Tekrar deneyeceğim.
İyi çalışmalar.

 

[halit3]

Alternatif olarak aşağıdaki linke dosya ekledim.

https://www.excel.web.tr/threads/pdf-dosyasindan-veri-alma.178060/