Kapalı Dosyadan Veri Alma

[askm]

Kolay gelsin.
Ekte 1 Adet DOSYA isimli excel belgem mevcut. Buna İzin Kaynak klasöründen B1 hücresinde yazılı olan Kapalı excel çalışma kitabından veri getirecek. Yalnız sadece DOSYA da belirtilen sütunları getirmesini gerekli. Verileri alırken Kaynak dosyadaki boşlukları ve başlıkları da iptal etmek mümkün müdür.
Teşekkürler.

 

[PLİNT]

Kolay gelsin.
Ekte 1 Adet DOSYA isimli excel belgem mevcut. Buna İzin Kaynak klasöründen B1 hücresinde yazılı olan Kapalı excel çalışma kitabından veri getirecek. Yalnız sadece DOSYA da belirtilen sütunları getirmesini gerekli. Verileri alırken Kaynak dosyadaki boşlukları ve başlıkları da iptal etmek mümkün müdür.
Teşekkürler.

Merhaba
Buraya http://s3.dosya.tc/ örnek eklermisiniz?

 

[askm]

Örneği yükledim

 

[PLİNT]

Örneği yükledim

Merhaba
Kusura bakmayın.

 

[askm]

Aşağıdaki kodlar ile verileri getirdim. yalnız aşağıdaki sorunlarım var.
1. Benim örnekteki gibi A3 den başlayarak tüm sütunları değilde sadece istediğim başlıkları getirmek.
2. Aradaki boşluk ve yenilenen başlıkları kaldırmak. kaynak dosya pdf evrak. Çeviri yapınca arada boş hücre ve başlıkların yinelenmesi oluyor. Bunları kaldırarak aldırma imkanı olur mu.


Bu kodlarda dosya ismini Sayfa2 A1 hücresine yazdırarak alabildim.
Sub Kapalıdan_Al()
Sayfa1.[a1:I65556].ClearContents
Dim Yol As String, BTipi As String
Dim Con As Object, Rs As Object, Sorgu As String
Set Con = CreateObject("Adodb.Connection")
Set Rs = CreateObject("Adodb.RecordSet")
adr = Mid(Sayfa2.Range("a1"), 1, 99)
Yol = ThisWorkbook.Path & "\İzin Kaynak\" & adr & " KAYNAK.xlsx"
Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
Yol & ";extended properties=""excel 12.0;hdr=no"""
Sorgu = "Select * from [Sayfa1$] 'where 1 <>''"
Rs.Open Sorgu, Con, 1, 1
Range("A1").CopyFromRecordset Rs
Rs.Close: Con.Close
Set Con = Nothing: Set Rs = Nothing: Sorgu = ""
End Sub

 

[askm]

Aşağıdaki kodlar ile hallettim.

Sub verial()
Set uygulama = CreateObject("Excel.Application")
adr = Mid(Sayfa1.Range("a1"), 1, 99)
Dim i As Integer
Dim j As Integer

Set dosya = uygulama.Workbooks.Open(ThisWorkbook.Path & "\İzin Kaynak\" & adr & " KAYNAK.xlsx")
son = [a65536].End(3).Row
sonsat = dosya.Sheets("Sayfa1").[a65536].End(3).Row

[a4:f65536].ClearContents
j = 4
For i = 2 To sonsat
If dosya.Sheets("Sayfa1").Cells(i, 2) = "" Or dosya.Sheets("Sayfa1").Cells(i, 2) = "SİCİL" Then

Else
Cells(j, 1) = dosya.Sheets("Sayfa1").Cells(i, 2).Value 'Sicil
Cells(j, 2) = dosya.Sheets("Sayfa1").Cells(i, 3).Value 'Adı Soyadı
Cells(j, 3) = dosya.Sheets("Sayfa1").Cells(i, 4).Value 'İzin Tipi
Cells(j, 4) = dosya.Sheets("Sayfa1").Cells(i, 5).Value 'BAŞLANGIÇ TARİHİ
Cells(j, 5) = dosya.Sheets("Sayfa1").Cells(i, 6).Value 'DÖNÜŞ TARİHİ
Cells(j, 6) = dosya.Sheets("Sayfa1").Cells(i, 7).Value 'İZİN SÜRESİ
j = j + 1
End If

Next

MsgBox "Veri alma işlemi tamamlandı."
10 dosya.Close
uygulama.Quit
End Sub