• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

O

ormann

Katılım
9 Ekim 2009
Mesajlar
1,626
Excel Vers. ve Dili
türkçe
2003
Merhabalar;
Sayın Korhan beyin yapmış olduğu ekli makro ile kapalı excel dosyasından dolu hücredeki verileri excel dosyasına alıyoruz. Aynı şartlarda PDF dosyasındaki 3. sutunun dolu olan hücrelerindeki verileri kayıt dosyasında dikili girişi sayfasındaki D20:D hücre aralığına aldırmak mümkün müdür.

İndir KAYIT

Dosyayı indir KAYIT
dosya.co

İndir VERİ ALINACAK PDF DOSYASI

Dosyayı indir VERİ ALINACAK PDF DOSYASI
dosya.co



Kod: 
Option Explicit

Sub Verileri_Al()
    Dim Dosya As String, Zaman As Double, Baglanti As Object, Kayit_Seti As Object, Sorgu As String
    
    ChDir ThisWorkbook.Path
    Dosya = Application.GetOpenFilename("Excel Dosyaları (*.xl*),*.xl*", , "Lütfen Veri Alınacak Dosyayı Seçiniz")
    
    If Dosya = "False" Then
        MsgBox "Dosya seçimi yapmadığınız için işleminiz iptal edilmiştir.", vbCritical
        Exit Sub
    End If
    
    Zaman = Timer
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
    Sorgu = "Select * From [Table 1$B6:C65000] Where F1 Is Not Null"
        
    Kayit_Seti.Open Sorgu, Baglanti, 1, 1
        
    If Kayit_Seti.RecordCount > 0 Then
        Range("D20:E" & Rows.Count).ClearContents
        Range("D20").CopyFromRecordset Kayit_Seti
    End If

    Kayit_Seti.Close
    Baglanti.Close
    
    Set Baglanti = Nothing
    Set Kayit_Seti = Nothing
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 
Verdiğiniz PDF'i online sitelerde komple Excel'e çevirip, istediğiniz verileri içinden almanız sizin için daha kolay olur bence.

Excel'e dönüştürülmüş PDF dosyası ektedir.

.
 

Ekli dosyalar

Haluk bey bu dosya gibi çok dosya var ve devamı da gelecek. Excele her defasında dönüştürme zor olacak gibi.Bunu kod ile yapmak mümkün değil midir
 
Yapılır da ... uğraşmak lazım.

.
 
Eklemiş olduğunuz PDF dosyası da muhtemelen Excel'de falan yapılmıştır..... Yapan kişiye söyleyin, size Excel olarak versin.

.
 
Bu dosya OGM'nin Veri tabanından indirme formatı Excel olarak değil .PDF olarak iniyor.
 
Bence kurumunuzun bilgi işlem sorumlusuyla görüşün, programın bir seçeneği vardır mutlaka ...

.
 
Alternatif olarak aşağıdaki linkdeki dosyayı indirin ve bilgisayarınıza kurun sonra pdf dosyasına mause ile sağ kılık yapın ve Dönüştür Aç seçeneğinden excelli seçin

PDF Dosyalarını Birleştirme ve ayrıştırma (Merge-Split) işlemleri

Not: Bu dosya ile yapılacak işlemler Pdf dosyalarını Birleştirmek ve ayırma işlemlerini yapmaktadır. uyarı: Bu dosyanın çalışabilmesi için bilgisayarınızda Adobe Acrobat DC PDF proğramı yüklü olması gerekiyor eğer yüklü değilse aşağıdaki linkdeki proğramı demo olarak yükleyiniz başkada bir...
www.excel.web.tr www.excel.web.tr

Yeni Bit Eşlem Resmi.jpg
 

Ekli dosyalar

Son düzenleme:
Sizin için bir alternatif hazırladım....

Ekli klasörü bilgisayarda bir yere yerleştirin, içindeki Excel dosyasını çalıştırın...... Klasör içinde yer alan PDF dosyasındaki 11 adet sayfanın içindeki tüm tablolardan nümerik veriler alınarak Excel sayfasına listelenecektir.

Bundan sonrasında artık, klasik VBA teknikleriyle istediğiniz sütundan, istediğiniz verileri alabilirsiniz...

.
 

Ekli dosyalar

İkinci bir alternatif ektedir.... bu dosyada, tablo içeriği daha anlamlı hale getirilmiştir.
 

Ekli dosyalar

Alternatif bir çözüm.
Kod: 
Sub PDFtoExcel()
    On Error Resume Next
    Dim dosyaYolu As String
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
            
        If .Show <> 0 Then
            dosyaYolu = .SelectedItems(1)
            Dim wrdApp As Object
            Set wrdApp = CreateObject("Word.Application")
            wrdApp.Visible = True
            
            Dim wrdDoc As Object

          
            Set wrdDoc = wrdApp.Documents.Open(dosyaYolu)
          
            With wrdDoc
                Dim tabloSayısı As Long
                tabloSayısı = .Tables.Count
 
                If tabloSayısı = 0 Then
                    Debug.Print "Herhangi bir tablo bulunamadı."
                    Exit Sub
                End If
 
                Dim i As Long
                Dim j As Byte
                Dim RowCount As Byte
                Dim k As Byte
                Dim sonSatir As Long
                ActiveSheet.UsedRange.ClearContents
                For i = 1 To tabloSayısı
    
                    RowCount = .Tables(i).Rows.Count
                    For j = 1 To RowCount
              
                        For k = 1 To 3
                            ActiveSheet.Cells(ActiveSheet.Range("A10000").End(xlUp).Row + 1, k) = .Tables(i).cell(j, k).Range.Text
                            If ActiveSheet.Cells(ActiveSheet.Range("A10000").End(xlUp).Row + 1, k).Value Like "*Ç*" Then
                                ActiveSheet.Cells(ActiveSheet.Range("A10000").End(xlUp).Row + 1, k) = ""
                            End If
                        Next k
                    Next j
        
                Next i
    
    
                Columns("B:B").Select
                Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
                Columns("C:C").Select
                Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
        
                Columns("A:A").Delete
                Columns("B:B").Select
                Selection.SpecialCells(xlCellTypeBlanks).Select
                Selection.EntireRow.Delete

  
            End With
            
            wrdDoc.Close
            wrdApp.Quit
        End If
        
    End With
 MsgBox "İşlem tamamlandı."
End Sub
 
Haluk Bey Merhaba,
Dosyanızı inceledim ilgimi çekti. Benimde ekte tek sayfalık bir pdf var excele aktaramadık. Aynı formatta birçok dosya olunca da
dönüştürücüler zaman alıyor. Sizin bu dosyada denedim beceremedim. Hata da vermedi. Yardımcı olursanız çok minnettar kalırım.

Saygıyla,
 

Ekli dosyalar

  • PDF.pdf
    PDF.pdf
    48.3 KB · Görüntüleme: 12
Verileri web ortamında tablo olarak görüntüledikten sonra pdf olarak indiriyorsanız. Chrome Copytables eklentisini öneririm, istediğiniz sütunu seçtikten sonra direk kopyalama yapabilirsiniz. Kopyalamak istediğiniz sütun/sutunları sütunun üzerindeyken Sağ mouse>Table> Select column ile seçebilirsiniz. Daha sonra Sağ mouse> Table>Copy>txt yaparak kopyalama işlemi tamamlanır, excelde istediğiniz hücreye de yapıştırırsınız.
Eklenti linki: https://chrome.google.com/webstore/detail/copytables/ekdpkppgmlalfkphpibadldikjimijon

yk0HJn.png
 
Sayın değerli hocalarım hepinize ayrı ayrı teşekkür ederim.Eklemiş olduğunuz dosyaların rica etsem linklerini ekleyebilir misiniz
 
ormann' Alıntı:
Sayın değerli hocalarım hepinize ayrı ayrı teşekkür ederim.Eklemiş olduğunuz dosyaların rica etsem linklerini ekleyebilir misiniz
Genişletmek için tıkla ...

İsteğiniz üzerine dosyayı harici linke de eklemiştim. İndirip, denediz mi?

.
 
Haluk bey merhabalar ;
Şu kodda hata veriyor
Set pages = pdfDoc.OpenPdf(dosya)
 
RAR klasörünü indirip, içindeki hiçbirşeye dokunmadan Excel'i çalıştırmadınız mı?

gifyu.com

TestHD

Image TestHD hosted in Gifyu
gifyu.com gifyu.com

.
 
O zaman yapacak birşeyim yok ...... belki kullandığınız Excel versiyonu ya da bilgisayar ayarlarınızla ilgilidir.

Umarım, dosyaların hepsini RAR klasöründen dışarıya çıkarttıktan sonra çalıştırmışınızdır....

.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst