Soru PDF dosyasındaki belirli veriyi excele kopyalamak

halit3 · 12 Nisan 2020

Ben farklı bir dosya ekliyorum bu dosyayı diğer dosyaların yanına koy ve kodu çalıştır doğum tarihini yıl olarak alıyor başkaca alınmasını istediğin veri varsa yazınız.

Diğer sorularına gelince benze formatdaki dosyalardan bu şekilde veriler alınabilir eğitim için araştırmak lazım ben bu konularda hiç eğitim almadım araştırarak konuları takip ederek birazda merak ve ilgiden dolayı buralara geldim.
Ama bu işe ilk başlayışım Excell makroları diye bir kitap almıştım.

seckinb · 16 Nisan 2020

PHP:

Private pdfDoc As PDFDocument, pages As PDFPageCollection

Private Sub CommandButton1_Click()
Set klasor = CreateObject("shell.application").BrowseForFolder(0, "Klasörü Seçin", 50, &H0)
If klasor Is Nothing Then Exit Sub
Kaynak = klasor.self.Path
'Kaynak = ThisWorkbook.Path & "\deneme"
'Liste (ThisWorkbook.Path)
Liste2 (Kaynak)
MsgBox "işlem tamam"
End Sub

Private Sub Liste2(yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

sat3 = 0

For Each Dosya In fL.GetFolder(yol).Files
dosya_adi = fL.GetBaseName(Dosya)

If LCase(fL.GetExtensionName(Dosya)) = "pdf" Then

sat3 = Cells(Rows.Count, "A").End(3).Row + 1

s = 0
Set pdfDoc = New PDFDocument
Set pages = pdfDoc.OpenPdf(Dosya)
say = 1

For t = 0 To pages.Count - 1

degg = pages(t).GetText
For k1 = 1 To 20
degg = Replace(degg, " ", "^")
Next k1

For k2 = 1 To 20
degg = Replace(degg, "^^", "^")
Next k2

For k3 = 1 To 20
degg = Replace(degg, "^", " ")
Next k3

deg55 = Split(degg, Chr(10))
If UBound(deg55) > 0 Then
For k4 = 0 To UBound(deg55) - 1
If Len(Trim(deg55(k4))) > 1 Then


deg1 = Split(deg55(k4), "Kimlik No")
If UBound(deg1) > 0 Then
Cells(sat3, "D").Value = Right(deg1(0), 12)
End If

deg4 = Split(deg55(k4), "Doğum Tarihi")
If UBound(deg4) > 0 Then
Cells(sat3, "E").Value = Right(deg55(k4), 5) * 1
End If


deg2 = Split(deg55(k4), "Yaş")
If UBound(deg2) > 0 Then
deg3 = Split(deg2(0), "Ad Soyad ")
If UBound(deg3) > 0 Then
Cells(sat3, "a").Value = Split(deg3(1), " ")(0)
Cells(sat3, "b").Value = Mid(deg3(1), Len(Split(deg3(1), " ")(0)) + 1, 100)
End If
End If

deg4 = Split(deg55(k4), "Ameliyat Ameliyat")
If UBound(deg4) > 0 Then
Cells(sat3, "I").Value = Trim(Left(deg55(k4 + 1), 11))
End If

End If
Next k4

End If
Next t

End If
Next
pdfDoc.ClosePdf
Set fL = Nothing

End Sub

Ufaktan modifiye ederek,
doğum tarihini E,
kimlik D,
ameliyat tarihini I sütununun sonuna eklemiş oldum.

Şimdi farklı bir buton yaparak, bu dosyadaki şu değerleri

istek tarihini AS
TG - AU
Anti TG - AV
TSH - AW

olacak şekilde ayrıca çekebilir miyim?

(Hasta bilgileri kurmacadır

)

Haluk · 16 Nisan 2020

Dosyanız ektedir....

.

seckinb · 16 Nisan 2020

Haluk' Alıntı:
Dosyanız ektedir....

.

kan değerlerinin sadece kendisine ihtiyacım var.

1,35 gibi

aralıkların yazdığı kısımları almaması için ne yapabilirim?

Haluk · 16 Nisan 2020

Kodda; aşağıdaki bölümü eskisinin yerine koyun...

Kod:

            arrPattern(1) = "Hasta Ad Soyad\s{1}(.+)"
            arrPattern(2) = "TC Kimlik No\s{1}(.+)"
            arrPattern(3) = "Doğum T\s{1}?arihi\s{1}(\d{1,2}\.\d{1,2}\.\d{4})"
            arrPattern(4) = "İstek T\s{1}?arihi\s{1}(\d{1,2}\.\d{1,2}\.\d{4})"
            arrPattern(5) = "TSH\s{1}(.+)\s{1}µIU\/ml"
            arrPattern(6) = "Serbest T3\s{1}(.+)\s{1}pg\/ml "
            arrPattern(7) = "Serbest T4\s{1}(.+)\s{1}ng\/dl"
            arrPattern(8) = "Anti Tiroglobulin\s{1}(.+)\s{1}IU\/ml"
            arrPattern(9) = "TG \(Tiroglobulin\)\s{1}(.+)\s{1}ng\/ml"

Değerlerin nümerik olması için de, aşağıdaki kırmızı ilaveleri yapın ....

Rich (BB code):

                        ElseIf arrIndex = 4 Then
                            Range("E" & i) = tempData + 0
                        ElseIf arrIndex = 5 Then
                            Range("F" & i) = Trim(tempData) + 0
                        ElseIf arrIndex = 6 Then
                            Range("G" & i) = tempData + 0
                        ElseIf arrIndex = 7 Then
                            Range("H" & i) = tempData + 0
                        ElseIf arrIndex = 8 Then
                            Range("I" & i) = tempData + 0
                        ElseIf arrIndex = 9 Then
                            Range("J" & i) = tempData + 0
                        End If

.
.

seckinb · 23 Nisan 2020

Haluk' Alıntı:
Dosyanız ektedir....

.

Kodu ihtiyacıma göre modifiye ettim lakin;
20.05.2019 olan tarihi istemiş olduğum AS hücresine önce 20052019 olarak yapıştırdı.
düzenlemek için aralardaki noktaları / ile değiştirdiğimde ise hiç yapıştırmadı.

PHP:

Sub SON_KONTROL()
'   Haluk - 16/04/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, valData As Variant, RetVal As Variant
    Dim arrPattern(1 To 9) As String
    Dim txtPDF As String, tempData As String, strAd As String, strSOYAD As String
    Dim NoA As Integer, i As Integer, arrIndex As Integer
    

    Set FSO = CreateObject("Scripting.FileSystemObject")
    folderpath = "C:\Users\SECKING\Desktop\pdf"
    
    i = 1
    For Each dosya In FSO.GetFolder(folderpath).Files
        If LCase(FSO.GetExtensionName(dosya)) = "pdf" Then
            NoA = Range("A" & Rows.Count).End(xlUp).Row + 1
            Set pdfDoc = New PDFDocument
            Set pages = pdfDoc.OpenPdf(dosya)
            
            For t = 0 To pages.Count - 1
                txtPDF = txtPDF & WorksheetFunction.Trim(pages(t).GetText) & vbCrLf
            Next
            
            arrPattern(1) = "Hasta Ad Soyad\s{1}(.+)"
            arrPattern(2) = "TC Kimlik No\s{1}(.+)"
            arrPattern(3) = "Doğum T\s{1}?arihi\s{1}(\d{1,2}\.\d{1,2}\.\d{4})"
            arrPattern(4) = "İstek T\s{1}?aihi\s{1}(\d{1,2}\.\d{1,2}\.\d{4})"
            arrPattern(5) = "TSH\s{1}(.+)\s{1}µIU\/ml"
            arrPattern(6) = "Serbest T3\s{1}(.+)\s{1}pg\/ml "
            arrPattern(7) = "Serbest T4\s{1}(.+)\s{1}ng\/dl"
            arrPattern(8) = "Anti Tiroglobulin\s{1}(.+)\s{1}IU\/ml"
            arrPattern(9) = "TG \(Tiroglobulin\)\s{1}(.+)\s{1}ng\/ml"
            
            Set regExp = CreateObject("VBScript.RegExp")
            
            regExp.IgnoreCase = True
'            regExp.MultiLine = True
            regExp.Global = True
            
            i = Range("A" & Rows.Count).End(xlUp).Row + 1
            arrIndex = 0
            For Each valData In arrPattern
                regExp.Pattern = valData
                arrIndex = arrIndex + 1
                If regExp.Test(txtPDF) Then
                    For Each RetVal In regExp.Execute(txtPDF)
                        tempData = RetVal.Submatches(0)
                        If arrIndex = 1 Then
                        '    strAd = Split(tempData, " ")(0)
                        '    strSOYAD = Trim(Replace(tempData, strAd, ""))
                        '    Range("A" & i) = strAd
                        '    Range("B" & i) = strSOYAD
                        'ElseIf arrIndex = 2 Then
                        '    Range("C" & i) = tempData
                        'ElseIf arrIndex = 3 Then
                        '    Range("D" & i) = tempData
                        ElseIf arrIndex = 4 Then
                            Range("AS" & i) = tempData + 0
                        ElseIf arrIndex = 5 Then
                            Range("AW" & i) = Trim(tempData) + 0
                        'ElseIf arrIndex = 6 Then
                        '    Range("G" & i) = tempData + 0
                        'ElseIf arrIndex = 7 Then
                        '    Range("" & i) = tempData + 0
                        ElseIf arrIndex = 8 Then
                            Range("AV" & i) = tempData + 0
                        ElseIf arrIndex = 9 Then
                            Range("AU" & i) = tempData + 0
                        End If
                    Next
                End If
            Next
        End If
        txtPDF = ""
    Next
    
    Set regExp = Nothing
    pdfDoc.ClosePdf
    Set pages = Nothing
    Set pdfDoc = Nothing
    Set FSO = Nothing
End Sub

Haluk · 23 Nisan 2020

20.05.2009 tarihi nerde var ?

Neyse ..... siz aşağıdaki "kırmızı" bölümü iptal edip, öyle deneyin;

Rich (BB code):

Range("AS" & i) = tempData + 0

.

seckinb · 23 Nisan 2020

Bir diğer sorun ise

kodun sonuna
"
pdfDoc.ClosePdf
"

eklemiş olmama rağmen açmış olduğu dosyayı kapatmıyor. bu nedenle dosyayı taşıyamıyorum.

Haluk · 23 Nisan 2020

Bilmiyorum, bende öyle bir problem yok...

.

seckinb · 23 Nisan 2020

Örnek olarak bu PDf dosyasında TSH değerini çekerken hata verdi. Bir başkasını denediğimde rahat çalıştı.

Haluk · 23 Nisan 2020

Daha önceki PDF dokümanı ile son eklediğiniz dokümanda TSH verileri birbirinden farklı.

İlkinde TSH verisi 0,325 iken son eklediğinizde 0,085 L verisi var. Yani biri "nümerik" diğeri "string" ifadeler.

Siz, hata veren satırda + 0 ifadesini silin .... veriler, "string" olarak gelir....!!

.

seckinb · 23 Nisan 2020

biokimya lab bazı hastalarda bu tip L ve H işaretleri ekliyor. bunu yoksayması mümkün mü?

Haluk · 23 Nisan 2020

Mümkün...

.

Haluk · 23 Nisan 2020

Dosyanız yeni duruma göre tekrar revize edildi....

.

seckinb · 23 Nisan 2020

Tarih ekleyen sutünu düzenelem için şöyle de küçük bir ekleme yaptım.
Ellerinize sağlık.

PHP:

                        ElseIf arrIndex = 4 Then
                            Range("AS" & i) = CDate(Trim(tempData))

seckinb · 25 Nisan 2020

PdfToText klasörünü excel dosyasının bulduğu klasör değil de, 2 üstteki parent klasörde saklamak istesem, nasıl başarabilirim?

Haluk · 25 Nisan 2020

Dosyadaki PDFDocument isimli Class Module içindeki Class_Initialize prosedüründe gerekli satırları değiştirmeniz gerekir....

.

seckinb · 7 Mayıs 2020

merhaba, sizden aldığım kod ile 2 farklı pdf türünün başarı ile girişini yapıyorum. lakin 1 adet daha uyarlamaya ihtiyacım var.

mevcut kullandığım excel ektedir.

Bu formdaki tarih verisini AI hücresinin en altına,
sarı ile çizdiğin sayı değerini ise AH hücresinin en altına eklemem gerekiyor.

Teşekkürler

Haluk · 7 Mayıs 2020

Dosyadaki hangi makroya ilave edilecek bu yeni verilerin alınması, belirtmemişiniz....

Alınacak "mCi" değeri her zaman 3 dijit mi olacak, ondalıklı sayı olabilir mi .... bunları da belirtmemişiniz.

Bu yüzden; sadece son eklediğiniz PDF dosyasındaki yapıya uygun olarak, söylediğiniz 2 adet veri için hazırladım dosyayı.

Dosyadaki "Test89" isimli makro bu verileri alıp, aktif sayfada "AH" ve "AI" sütunlarında son hücreye yerleştirir.

.

seckinb · 7 Mayıs 2020

Yeni bir makro olarak düşünmüştüm. Ona da diğerleri gibi buton yapardım.

Soru PDF dosyasındaki belirli veriyi excele kopyalamak

halit3

Uzman

Ekli dosyalar

seckinb

Ekli dosyalar

Haluk

Özel Üye

Ekli dosyalar

seckinb

Haluk

Özel Üye

seckinb

Haluk

Özel Üye

seckinb

Haluk

Özel Üye

seckinb

Ekli dosyalar

Haluk

Özel Üye

seckinb

Haluk

Özel Üye

Haluk

Özel Üye

Ekli dosyalar

seckinb

seckinb

Haluk

Özel Üye

seckinb

Ekli dosyalar

Haluk

Özel Üye

Ekli dosyalar

seckinb