• DİKKAT

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

diğer dosyalardan istenilen tarihi çekmek

Ş

şehiriçi

Katılım
1 Ağustos 2013
Mesajlar
563
Excel Vers. ve Dili
Ofis 2016 TR 32 Bit
merhaba arkadaşlar ;
özel1 dosyasına diğer dosyalardan istediğim tarihlerdeki verileri makro ile döndürmek istiyorum
 

Ekli dosyalar

kod:
Kod: 
Sub veri_al()

b = MsgBox("Sayfayı temizlemek istiyormusunuz.?", vbYesNo) 'Mesaj.İsteğe bağlı yazılmayabilir.
If b = vbYes Then
Range(Cells(4, 1), Cells(Rows.Count, Columns.Count)).ClearContents
End If

Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path

If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
deger1 = Cells(1, 3)

Liste (Klasor.Items.Item.Path)

Cells(1, 3) = deger1
MsgBox "işlem tamam"

Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
    
Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
Hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number

End Sub
 
Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fs = CreateObject("Scripting.FileSystemObject")

ReDim yer(100)
tarih = Cells(1, 1)

aranan_Uzanti = fs.GetExtensionName(Application.AddIns.Item(1).FullName)

For Each dosya In fs.GetFolder(yol).Files

Uzanti = fs.GetExtensionName(dosya.Name)
If aranan_Uzanti = "xlam" Then
If Uzanti = "xls" Or Uzanti = "xlsm" Or Uzanti = "xlsx" Or Uzanti = "xlsb" Then
Else
GoTo Atla1
End If
End If

If aranan_Uzanti = "xla" Then
If Uzanti <> "xls" Then
GoTo Atla1
Else
End If
End If


If ThisWorkbook.Name <> dosya.Name Then
For t = 1 To 100
yer(t) = ""
Next


say1 = 0
Dim Katalog As Object, Data As Object, Tablo As Object
Dim son1
Set Data = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")
Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & dosya & ";"
Katalog.ActiveConnection = Data

For Each Tablo In Katalog.Tables

If InStr(1, Tablo.Type, "TABLE") > 0 Then
If Right(Tablo.Name, 19) <> "kaynağından_sorgula" Then
If Right(Tablo.Name, 14) <> "Yazdırma_Alanı" Then
son1 = Replace(Tablo.Name, "'", "")
If Right(son1, 1) <> "_" Then
If Right(son1, 1) = "$" Then
son1 = Left$(son1, Len(son1) - 1)
If UBound(Split(son1, "#")) = 0 Then
Else
say1 = say1 + 1
yer(say1) = Replace(son1, "#", ".")
End If
say1 = say1 + 1
yer(say1) = son1
End If
End If

End If
End If
End If
Next
Data.Close
Set Data = Nothing
Set Katalog = Nothing

Kalasor2 = fs.GetParentFolderName(dosya)

If Right(Kalasor2, 1) <> "\" Then Kalasor2 = Kalasor2 & "\"

For mat = 1 To say1
SayfaAdi = yer(mat)
deg2 = Kalasor2 & "[" & dosya.Name & "]" & SayfaAdi
deg3 = "'" & Kalasor2 & "[" & dosya.Name & "]" & SayfaAdi & "'!R"

sonsat = Rows.Count - 1
veri_alinacak_bas_sat = 3  'veri alınacak başlangıç satır numarası
veri_alinacak_bas_sut = 1  'veri alınacak başlangıç sütun numarası
bas_satun_no = 3           'yazmaya başlıyacak ilk sütun

'---------------------------------------------------------------------------------------

kap_dos_sütün_no = Split(Cells(1, 1).Address, "$")(1)
kap_dos_satir_no = Cells(1, 1).Row

yer1 = "LOOKUP(2,1/('" & deg2 & "'!" & kap_dos_satir_no & ":" & kap_dos_satir_no & "<>""""),COLUMN('" & deg2 & "'!" & kap_dos_satir_no & ":" & kap_dos_satir_no & "))"
Cells(1, 3).Value = "=IF(ISERROR(" & yer1 & "),""""," & yer1 & ")"
sut1 = Cells(1, 3).Value ' Kapalı dosyaya ait son dolu sütun sayısı
yer2 = "LOOKUP(2,1/('" & deg2 & "'!" & kap_dos_sütün_no & "1:" & kap_dos_sütün_no & sonsat & "<>""""),ROW('" & deg2 & "'!" & kap_dos_sütün_no & ":" & kap_dos_sütün_no & "))"
Cells(1, 3).Value = "=IF(ISERROR(" & yer2 & "),""""," & yer2 & ")"
sat1 = Cells(1, 3).Value ' Kapalı dosyaya ait son dolu satır sayısı

bas_satir_no = Cells(Rows.Count, "A").End(3).Row + 1
If bas_satir_no <= 4 Then bas_satir_no = 4

If Val(sut1) = 0 Or Val(sat1) = 0 Then MsgBox "son dolu satır ve son dolu sütunda değer yok": GoTo Atla1
If Val(veri_alinacak_bas_sat) > Val(sat1) Then MsgBox "veri alınacak başlangıç satır son dolu satırdan büyük olamaz.": GoTo Atla1
If Val(veri_alinacak_bas_sut) > Val(sut1) Then MsgBox "veri alınacak başlangıç satır son dolu sütundan büyük olabaz": GoTo Atla1

For r = veri_alinacak_bas_sat To sat1 ' Kapalı dosyaya ait son dolu satır sayısı

If CDate(ExecuteExcel4Macro(deg3 & r & "C" & 1)) = CDate(tarih) Then

Cells(bas_satir_no, 1) = dosya.Name
Cells(bas_satir_no, 2) = SayfaAdi
Cells(bas_satir_no, 3).Value = ExecuteExcel4Macro(deg3 & r & "C" & 2) 'kapalı dosyadaki değerlere ait prosüdür
Cells(bas_satir_no, 4).Value = ExecuteExcel4Macro(deg3 & r & "C" & 4) 'kapalı dosyadaki değerlere ait prosüdür
Cells(bas_satir_no, 5).Value = CDate(ExecuteExcel4Macro(deg3 & r & "C" & 1)) 'kapalı dosyadaki değerlere ait prosüdür
bas_satir_no = bas_satir_no + 1

If Rows.Count - 1 <= r Then Exit For
End If
Next r

Atla1:
Next mat

End If

Next

On Error GoTo sonraki
For Each f In fs.GetFolder(yol).SubFolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 
Dosyaların hepsi aynı klasör içinde olacak şekilde ADO ile alternatif çözüm..
Kod: 
[FONT="Trebuchet MS"][SIZE="2"]Sub Emre()
    Dim con As Object, rs As Object, evn As Object, cat As Object, dosya As Object, sorgu$, son%
    Set evn = CreateObject("[COLOR="Red"]scripting.filesystemobject[/COLOR]")
    Set con = CreateObject("[COLOR="red"]adodb.connection[/COLOR]")
    Set rs = CreateObject("[COLOR="red"]adodb.recordset[/COLOR]")
    Set cat = CreateObject("[COLOR="red"]adox.catalog[/COLOR]")
    For Each dosya In evn.[COLOR="red"]getfolder[/COLOR]([COLOR="Blue"]ThisWorkbook.Path[/COLOR]).[COLOR="Red"]Files[/COLOR]
        If dosya.Name <> ThisWorkbook.Name Then
            con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
            dosya & ";extended properties=""Excel 12.0;hdr=yes"""
            Set cat.[COLOR="red"]ActiveConnection [/COLOR]= con
            For Each sayfa In cat.[COLOR="Red"]Tables[/COLOR]
                sorgu = "select count([COLOR="red"]*[/COLOR]) from [" & [COLOR="Red"]Replace[/COLOR](sayfa.Name, "'", "") & "a2:a65000] where not [COLOR="red"]isnull[/COLOR](tarih)"
                rs.[COLOR="red"]Open [/COLOR]sorgu, con, 1, 1
                Range("F1").[COLOR="red"]CopyFromRecordset [/COLOR][COLOR="blue"]rs[/COLOR]
                son = Range("F1").Value + 2
                rs.Close
                sorgu = "Select [kğ], [miktar] From [" & [COLOR="Red"]Replace[/COLOR](sayfa.Name, "'", "") & "A2:D" & son & "]"
                sorgu = sorgu & " where not [COLOR="red"]isnull[/COLOR]([tarih]) [COLOR="Blue"]and [/COLOR][COLOR="red"]cdate[/COLOR]([tarih])='" & [COLOR="Red"]CDate[/COLOR](Range("A1").Value) & "'"
                rs.[COLOR="red"]Open [/COLOR]sorgu, con, 1, 1
                If rs.[COLOR="red"]RecordCount [/COLOR]> 0 Then
                    Range("A65536").End(3)[COLOR="red"](2, 1)[/COLOR] = [COLOR="red"]Split[/COLOR](dosya.Name, ".")([COLOR="red"]0[/COLOR])
                    Range("B65536").End(3)[COLOR="Red"](2, 1)[/COLOR] = [COLOR="red"]Replace[/COLOR](sayfa.Name, "$", "")
                    Range("C65536").End(3)[COLOR="red"](2, 1)[/COLOR].[COLOR="red"]CopyFromRecordset [/COLOR][COLOR="Blue"]rs[/COLOR]
                End If
                rs.[COLOR="Red"]Close[/COLOR]
            Next sayfa
            con.[COLOR="red"]Close[/COLOR]
        End If
    Next dosya
    son = Empty: sorgu = "": Set dosya = Nothing: Set cat = Nothing
    Set evn = Nothing: Set rs = Nothing: Set con = Nothing
End Sub[/SIZE][/FONT]
 
sayın halit3 ve murat osma ilginize çok teşekkürler
inanın sormaya çekiniyorum makrolara ilgim henüz taze verdiğiniz kodları ilgili sayfanın kod bölümüne yazıyorum ama çalıştıramıyorum .
 
şehiriçi' Alıntı:
sayın halit3 ve murat osma ilginize çok teşekkürler
inanın sormaya çekiniyorum makrolara ilgim henüz taze verdiğiniz kodları ilgili sayfanın kod bölümüne yazıyorum ama çalıştıramıyorum .
Genişletmek için tıkla ...

Dosyanız ekte

Bu dosyadaki komut düğmesine tıklayınız ve veri alınacak klasörü seçin tamamı tıklayın
 

Ekli dosyalar

Dosya işinizi gördümü ?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst