pdf dosyalarından veri çekme

[bulentarli]

Ekte sunmuş olduğum pdf dosyalarının bulunduğu klasörden, ekte bulunan Excel çalışma sayfasına veri çekebilmek mümkün müdür?

 

[Zeki Gürsoy]

Bunların yerine, faturaların XML dosyalarını eklerseniz daha isabetli sonuçlar alırsınız.

.

 

[bulentarli]

Zeki Hocam xml dosyalarını ekledim

 

[halit3]

Bu dosyayı bir dene inşallah olmuştur.

 

[halit3]

XML Kodu

Sub Deneme555()

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Range("A2:G1000") = ""
'sat = Worksheets(ActiveSheet.Name).Cells(Rows.Count, 1).End(3).Row + 1
sat = 1
For Each dosya In fL.GetFolder(ThisWorkbook.Path).Files
If LCase(fL.GetExtensionName(dosya)) <> "xml" Then GoTo atla

Set xmlhttp = CreateObject("MSXML2.XMLHTTP")

xmlhttp.Open "GET", dosya, False
xmlhttp.send "at"
isim2 = xmlhttp.responseText

sat = sat + 1

deg4 = Split(isim2, "<cbc:IssueDate>")
deg1 = Split(isim2, "<cac:Item>")
deg2 = Split(isim2, "<cac:Price>")
deg5 = Split(isim2, "<cbc:InvoicedQuantity unitCode")

If UBound(deg1) > 0 Then

For k = 1 To UBound(deg1)
sat = sat + 1

Cells(sat, 4) = Split(Split(deg5(k), ">")(1), "<")(0)
Cells(sat, 1) = Split(deg4(1), "</cbc:IssueDate>")(0)
Cells(sat, 2) = fL.GetBaseName(dosya.Name)

deg3 = Split(Split(deg1(k), "</cac:InvoiceLine>")(0), "<cbc:Name>")

Cells(sat, 3) = Split(deg3(1), "</cbc:Name>")(0)
Cells(sat, 5) = Split(Split(deg2(k), "</cbc:PriceAmount>")(0), ">")(1)

Next k
End If

atla:

Next
MsgBox "İşlem Tamam"
End Sub

 

[bulentarli]

Halit hocam teşekkür ediyorum emeğinize sağlık. Ancak işlemi 1,5 Dakikada gerçekleştiriyor ve dosya içerisine başka PDF dosyaları da ekledim onları görmüyor.

 

[halit3]

1 nolu mesaja eklediğiniz örnek pdf dosyalarındaki verileri alıyor.
eğer başka pdf dosyalarındaki veriler gelmiyorsa buraya ekleyin bir bakalım.

diğer taraftan iki dosyadan veri almak bir kaç saniye sürüyor 1,5 dakika sürmemesi gerekiyor.

 

[bulentarli]

diğer 2 dosya haricinde bu PDF'i denedim. Sadece ilk eklediğiniz PDF'i alıyor.

 

[halit3]

Bir kontrol et

 

[bulentarli]

Halit hocam çeok teşekkür ediyorum elinize, emeğinize sağlık.

 

[halit3]

Halit hocam çeok teşekkür ediyorum elinize, emeğinize sağlık.

Teşekkürler iyi çalışmalar

 

[muzaffer.sm]

Halit Abi,
Başka konuları gezerken Cevaplayanın siz olduğuna ayrıca sevindim. Forumda epeydir yoktunuz sizi görmek çok güzel
hoş geldiniz.

Bende bu konuyu inceledim mesleği muhasebecilik olanların olmazsa olmazlarından birisi olan bu konuyu.

Dosyada bir kısım nokta var onu nasıl çözdünüz acaba ?

 

[halit3]

Halit Abi,
Başka konuları gezerken Cevaplayanın siz olduğuna ayrıca sevindim. Forumda epeydir yoktunuz sizi görmek çok güzel
hoş geldiniz.

Bende bu konuyu inceledim mesleği muhasebecilik olanların olmazsa olmazlarından birisi olan bu konuyu.

Dosyada bir kısım nokta var onu nasıl çözdünüz acaba ?

Benim eklediğim dosyada ondalık ayırgaç (virgül) var senin eklediğin dosyada yok

 

[muzaffer.sm]

9.Nolu mesajdaki dosyanızı indirip incelemiştim. Fatura döküm excel kitabını deneyerek yapmıştım. İndirdiğim dosyaları ilk açtığımda ondalık haneler ayrılmış görünüyor.
Düğmeyi sıfırdan çalıştırdığım zaman bende ayraçlar kayboluyor. Sanırım bölgesel ayarlardan kaynaklı bir durum bu

 

[halit3]

Dosyada ikinci sayfadan veri alırken ilk baştaki veriyi atlıyordu düzeltildi.

 

[1903emre34@gmail.com]

Merhaba,

Ekteki belgede çizili alan excel aktarmak için yardımcı olabilir misiniz

 

[halit3]

Merhaba,

Ekteki belgede çizili alan excel aktarmak için yardımcı olabilir misiniz

Sorunuzun yeri burası değil konular tamamen farklı, talebinizde yetersiz şimdi kodları ekliyorum buraya örnek dosyanızda belirttiğiniz gibi ama size çözüm olamayacağı düşünüyorom şimdi bununla ilgili bir çok sorunuz olacak benim esas dosyam bu değildi dosyam farklı diyeceksiniz.

Buyurun kod:
Tabi şunuda belirtiyim kodun çalışması için bu konudaki dll dosyaları dosyanın yanında olmalı

Sub Deneme1()
Dim pdfDoc As PDFDocument, pages As PDFPageCollection
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

Range("E2:E1000") = ""

sat = Worksheets(ActiveSheet.Name).Cells(Rows.Count, 5).End(3).Row + 1


For Each dosya In fL.GetFolder(ThisWorkbook.Path).Files
If LCase(fL.GetExtensionName(dosya)) <> "pdf" Then GoTo atla
Set pdfDoc = New PDFDocument
Set pages = pdfDoc.OpenPdf(dosya) 'Parola olmadığı varsayıldı.

deg = ""
For j = 0 To pages.Count - 1
deg = deg & Chr(10) & pages(j).GetText
Next j


For k = 1 To 10
deg = Replace(deg, " ", "^")
Next k

For k = 1 To 10
deg = Replace(deg, "^^", "^")
Next k

For k = 1 To 10
deg = Replace(deg, "^", " ")
Next k

deg1 = Split(Trim(deg), "Tüketim L")

If UBound(deg1) > 0 Then
Cells(sat, 5) = Split(deg1(1), Chr(10))(0)

End If

pdfDoc.ClosePdf
atla:

Next
MsgBox "İşlem Tamam"
End Sub