Soru Kapalı Dosyadan Dolu Hücrelerdeki Verileri Almak

[ormann]

İyi günler ;
Ekte iki adet dosyam var. Bir Veri alınacak dosya. Diğeri ise kayıt dosyam.Kayıt dosyasında Dikili Girişi sayfasında ki veri al butonu ile veri alınacak dosyadaki Table 1 sayfasında B6:C65000 hücre aralığındaki dolu verileri Kayıt sayfasında D20:E65000 hücre aralığına makro ile alabilir miyiz.Yalnız Table 1 sayfasında B6:C65000 hücre aralığındaki boş hücreler alınmayacak.Yardımlarınız bekliyorum.Saygılar

İndir VERİ ALANACAK DOSYA

Dosyayı indir VERİ ALANACAK DOSYA

dosya.co

İndir KAYIT

Dosyayı indir KAYIT

dosya.co

 

[muratboz06]

Sub verilirAl()

    Dim kaynakDosya As Workbook
    Dim hedefSayfa As Worksheet
    Set hedefSayfa = ThisWorkbook.Worksheets("DİKİLİ GİRİŞİ")
    Set kaynakDosya = Workbooks.Open(Filename:=ThisWorkbook.Path & "\VERİ ALANACAK DOSYA.xlsm")
   
    Dim sonSatir As Long
    sonSatir = kaynakDosya.Worksheets("Table 1").UsedRange.Rows.Count

    Dim arr As Variant
    arr = kaynakDosya.Worksheets("Table 1").Range("B6:C" & sonSatir)
    hedefSayfa.Range("D20:E" & sonSatir + 14) = arr
   
    kaynakDosya.Close
   
    Dim i As Long
    For i = 20 To sonSatir + 14
        If IsEmpty(hedefSayfa.Range("D" & i)) Then
            hedefSayfa.Range("D" & i).EntireRow.Delete
     End If
    Next i
   
    MsgBox "İşlem tamamlandı."
   
End Sub

 

[ormann]

Murat bey çok teşekkür ederim. Veri alınacak dosyayı biz seçebilir miyiz ?. Dosya Aç gibi . Birde Veri alınacak dosyada Table 1 sayfasında G1 hücresindeki veriyi Kayıt dosyasında Dikili girişi sayfasında H5 hücresine alabilir miyiz ?

 

[muratboz06]

Deneyiniz.

Sub verilirAl()
    Dim dosyaYolu As String
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
            
        If .Show <> 0 Then
            dosyaYolu = .SelectedItems(1)

            Dim kaynakDosya As Workbook
            Set kaynakDosya = Workbooks.Open(dosyaYolu)
    
            Dim hedefSayfa As Worksheet
            Set hedefSayfa = ThisWorkbook.Worksheets("DİKİLİ GİRİŞİ")

    
            Dim sonSatir As Long
            sonSatir = kaynakDosya.Worksheets("Table 1").UsedRange.Rows.Count
  
            Dim arr As Variant
            arr = kaynakDosya.Worksheets("Table 1").Range("B6:C" & sonSatir)
            hedefSayfa.Range("D20:E" & sonSatir + 14) = arr
    
            arr = kaynakDosya.Worksheets("Table 1").Range("G1")
            hedefSayfa.Range("H5") = arr
    
            kaynakDosya.Close
    
            Dim i As Long
            For i = 20 To sonSatir + 14
                If IsEmpty(hedefSayfa.Range("D" & i)) Then
                    hedefSayfa.Range("D" & i).EntireRow.Delete
                End If
            Next i
            MsgBox "İşlem tamamlandı."
        Else
            MsgBox "İşlem iptal edildi."

        End If
    End With
  
End Sub

 

[ormann]

Murat bey çok teşekkür ederim. Ellerinize sağlık. Kodlar tam istediğim şekilde çalışıyor. Acaba Kapalı PDF dosyasından da aynı bu şekilde excele veri alınabilir mi?

 

[Korhan Ayhan]

Alternatif;

ADO kodları;

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

 

[ormann]

Korhan bey ayrıca size de çok teşekkür ederim.
Acaba Kapalı PDF dosyasından da aynı bu şekilde excele veri alınabilir mi?

 

[Korhan Ayhan]

@Haluk beyin bu konuda paylaştığı dosyalar vardı. Arama yaparsanız bulursunuz.

 

[Erdem Akdemir]

@Zeki Gürsoy'un pdf'ten veri alınması ile ilgili çalışmaları mevcut.Onları'da araştırabilirsiniz.

 

[Haluk]

@Zeki Gürsoy'un pdf'ten veri alınması ile ilgili çalışmaları mevcut.Onları'da araştırabilirsiniz.

Zaten benim forumdaki PDF'ten veri alma işi yapan kodların hepsi Zeki Beyin sağladığı DLL'ler ve Class Module kodları sayesinde çalışıyor. Onlar olmadan mümkün değil ...

.