Çözüldü PDF'ten Veri Almak

lon_tokyo

Altın Üye
Katılım
27 Mayıs 2012
Mesajlar
27
Beğeniler
2
Excel Vers. ve Dili
Office 2016 - ENG
#1
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


Kod:
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
 
Katılım
27 Mayıs 2012
Mesajlar
27
Beğeniler
2
Excel Vers. ve Dili
Office 2016 - ENG
#2
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.
Kod:
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

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
235
Beğeniler
5
Excel Vers. ve Dili
2009
#3
strPath = yolum & "\"

buraya kendi dosya yolumu yazdım fakat

strFile = Dir(strPath) burada hata verdi. Örnek dosya yüklemeniz mümkün mü?
 
Katılım
27 Mayıs 2012
Mesajlar
27
Beğeniler
2
Excel Vers. ve Dili
Office 2016 - ENG
#4
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
 

Ekli dosyalar

Katılım
29 Ekim 2010
Mesajlar
327
Beğeniler
2
Excel Vers. ve Dili
office 2010 64 bit
#6
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.
 
Katılım
8 Eylül 2008
Mesajlar
732
Beğeniler
13
Excel Vers. ve Dili
2010 İngilizce
#7
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.
 
Katılım
27 Mayıs 2012
Mesajlar
27
Beğeniler
2
Excel Vers. ve Dili
Office 2016 - ENG
#8
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.

Capture.JPG
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.
 
Katılım
30 Temmuz 2012
Mesajlar
1,684
Beğeniler
73
Excel Vers. ve Dili
2010 - Türkçe 64 Bit
#10
Merhaba Sayın Ion_tokyo,
Teşekkürler. Ama sayfaların her noktasını okuyamıyor sanırım.
İyi çalışmalar
 
Katılım
27 Mayıs 2012
Mesajlar
27
Beğeniler
2
Excel Vers. ve Dili
Office 2016 - ENG
#11
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
 
Üst