Kapalı Dosyadan Veri Aktarma

  • Konuyu başlatan Konuyu başlatan gicimi
  • Başlangıç tarihi Başlangıç tarihi
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...

gicimi

Katılım
26 Haz 2018
Mesajlar
173
Excel Versiyonu
Excel 2016
Excel Sürümü
64 Bit
Excel Dili
Türkçe
Merhaba;

Masaüstü Kapalı Dosyalar adındaki klasörün altında 30 adet excel çalışma kitapları yer almaktadır.

Kapalı ve Açık dosyanın başlıkları aynıdır.
A2-DU2 Arası Standart Başlıklar bulunmaktadır.
30 adet farklı çalışma kitaplarındaki toplam satır sayısı 50.000 adettir.

"A1" hücresinde belirtilen sayı yada metini" kapalı 30 adet sayfada arama yapıp bulması durumunda ilgili satırların A-B-C-D-E-F-G-H sütunlarının bilgilerini "Data Report" çalışma kitabına aktarmak istiyorum. Nasıl bir kod yazılabilir.

Değerli üstadların yardımlarını bekliyorum. Teşekkürler.
 
Puantaj Günlerine Göre Renklendirme Yapma
Yıllık izin Takip Geliştirme

Ekli dosyalar

Çözüm
Sn. @gicimi kodlarda bir revizyon yaptım. Güncel kod aşağıdaki gibidir. Dosya yoluna dikkat edelim Masa üstünde "Kapalı Dosyalar" klasöründe olmalı dosyalar.

VBA: 
Sub ExcelDepo()
' www.ExcelDepo.com metehan8001****
Dim Con As Object, Rs As Object, Rss As Object, Fso As Object, Klasor As Object, Dosyalar As Object, ws As Object
Dim Sorgu As String, Dosya As String, Desk As String, Dosya_Yolu As String
Set Con = CreateObject("AdoDb.Connection")
Set Rs = CreateObject("AdoDb.RecordSet")
Set Rss = CreateObject("AdoDb.RecordSet")
Set Fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("WScript.Shell")
Desk = ws.SpecialFolders("Desktop")
Dosya_Yolu = Desk & "\Kapalı Dosyalar\"
Set Klasor =...
Tarihe göre sırala Oylamaya göre sırala
VBA: 
Sub ExcelDepo()
' www.ExcelDepo.com
Dim Con As Object, Rs As Object, Rss As Object, Fso As Object, Klasor As Object, Dosyalar As Object, ws As Object
Dim Sorgu As String, Dosya As String, Desk As String, Dosya_Yolu As String
Set Con = CreateObject("AdoDb.Connection")
Set Rs = CreateObject("AdoDb.RecordSet")
Set Rss = CreateObject("AdoDb.RecordSet")
Set Fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("WScript.Shell")
Desk = ws.SpecialFolders("Desktop")
Dosya_Yolu = Desk & "\Kapalı Dosyalar\"
Set Klasor = Fso.GetFolder(Dosya_Yolu)
Range("A3:DU65536").ClearContents
For Each Dosyalar In Klasor.Files
Con.Open "provider=Microsoft.Ace.OleDb.12.0;Data Source=" & Dosyalar & _
";Extended Properties=""Excel 12.0;HDR=no"""
a = Range("A1").Value
If IsNumeric(a) Then
i = "clng(" & a & ")"
Else
i = "'" & a & "'"
End If
x = InStr(i, ".")
If x <> 0 Then i = "'" & a & "'"
i1 = " and clng(f1) =" & i & "": i2 = " or (f2) =" & i & "": i3 = " or (f3)=" & i & "":
i4 = " or f4 =" & i & "": i5 = " or clng(f5) =" & i & "": i6 = " or clng(f6) =" & i & "":
i7 = " or f7 =" & i & "": i8 = " or clng(f8) =" & i & "": i9 = " or f9 =" & i & "":
i10 = " or f10 =" & i & "": i11 = " or clng(f11) =" & i & "": i12 = " or f12 =" & i & "":
i13 = " or f13 =" & i & "": i14 = " or f14 =" & i & "": i15 = " or f15 =" & i & "":
i16 = " or f16 =" & i & "": i17 = " or f17 =" & i & "": i18 = " or f18 =" & i & "":
i19 = " or f19 =" & i & "": i20 = " or f20 =" & i & "": i21 = " or f21 =" & i & "":
i22 = " or f22 =" & i & "": i23 = " or f23 =" & i & "": i24 = " or f24 =" & i & "":
i25 = " or f25 =" & i & "": i26 = " or f26 =" & i & "": i27 = " or f27 =" & i & "":
i28 = " or f28 =" & i & "": i29 = " or f29 =" & i & "": i30 = " or f30 =" & i & "":
i31 = " or f31 =" & i & "": i32 = " or f32 =" & i & "": i33 = " or f33 =" & i & "":
i34 = " or f34 =" & i & "": i35 = " or f35 =" & i & "": i36 = " or f36 =" & i & "":
i37 = " or f37 =" & i & "": i38 = " or f38 =" & i & "": i39 = " or f39 =" & i & "":
i40 = " or f40 =" & i & "": i41 = " or f41 =" & i & "": i42 = " or f42 =" & i & "":
i43 = " or f43 =" & i & "": i44 = " or f44 =" & i & "": i45 = " or f45 =" & i & "":
i46 = " or f46 =" & i & "": i47 = " or f47 =" & i & "": i48 = " or f48 =" & i & "":
i49 = " or f49 =" & i & "": i50 = " or f50 =" & i & "": i51 = " or f51 =" & i & "":
i52 = " or f52 =" & i & "": i53 = " or f53 =" & i & "": i54 = " or f54 =" & i & "":
i55 = " or f55 =" & i & "": i56 = " or f56 =" & i & "": i57 = " or f57 =" & i & "":
i58 = " or f58 =" & i & "": i59 = " or f59 =" & i & "": i60 = " or f60 =" & i & "":
i61 = " or f61 =" & i & "": i62 = " or f62 =" & i & "": i63 = " or f63 =" & i & "":
i64 = " or f64 =" & i & "": i65 = " or f65 =" & i & "": i66 = " or f66 =" & i & "":
i67 = " or f67 =" & i & "": i68 = " or f68 =" & i & "": i69 = " or f69 =" & i & "":
i70 = " or f70 =" & i & "": i71 = " or f71 =" & i & "": i72 = " or f72 =" & i & "":
i73 = " or f73 =" & i & "": i74 = " or f74 =" & i & "": i75 = " or f75 =" & i & "":
i76 = " or f76 =" & i & "": i77 = " or f77 =" & i & "": i78 = " or f78 =" & i & "":
i79 = " or f79 =" & i & "": i80 = " or f80 =" & i & "":
i81 = " and f81 =" & i & "":
i82 = " or f82 =" & i & "": i83 = " or f83 =" & i & "": i84 = " or f84 =" & i & "":
i85 = " or f85 =" & i & "": i86 = " or f86 =" & i & "": i87 = " or f87 =" & i & "":
i88 = " or f88 =" & i & "": i89 = " or f89 =" & i & "": i90 = " or f90 =" & i & "":
i91 = " or f91 =" & i & "": i92 = " or f92 =" & i & "": i93 = " or f93 =" & i & "":
i94 = " or f94 =" & i & "": i95 = " or f95 =" & i & "": i96 = " or f96 =" & i & "":
i97 = " or f97 =" & i & "": i98 = " or f98 =" & i & "": i99 = " or f99 =" & i & "":
i100 = " or f100 =" & i & "": i101 = " or f101 =" & i & "": i102 = " or f102 =" & i & "":
i103 = " or f103 =" & i & "": i104 = " or f104 =" & i & "": i105 = " or f105 =" & i & "":
i106 = " or f106 =" & i & "": i107 = " or f107 =" & i & "": i108 = " or f108 =" & i & "":
i109 = " or f109 =" & i & "": i110 = " or f110 =" & i & "": i111 = " or f111 =" & i & "":
i112 = " or f112 =" & i & "": i113 = " or f113 =" & i & "": i114 = " or f114 =" & i & "":
i115 = " or f115 =" & i & "": i116 = " or f116 =" & i & "": i117 = " or f117 =" & i & "":
i118 = " or f118 =" & i & "": i119 = " or f119 =" & i & "": i120 = " or f120 =" & i & "":
i121 = " or f121 =" & i & "": i122 = " or f122 =" & i & "": i123 = " or f123 =" & i & "":
i124 = " or f124 =" & i & "": i125 = " or f125 =" & i & "":
Sorgu = "Select f1,f2,f3,f4,f5,f6,f7 FROM [Sayfa1$A2:DU] where 1=1  " & i1 & i2 & i3 & i4 & i5 & i6 & i7 & i8 & i9 & i10 & i11 & i12 & i13 & i14 & i15 & i16 & i17 & i18 & i19 & i20 & i21 & i22 & i23 & i24 & i25 & i26 & i27 & i28 & i29 & i30 & i31 & i32 & i33 & i34 & i35 & i36 & i37 & i38 & i39 & i40 & i41 & i42 & i43 & i44 & i45 & i46 & i47 & i48 & i49 & i50 & i51 & i52 & i53 & i54 & i55 & i56 & i57 & i58 & i59 & i60 & i61 & i62 & i63 & i64 & i65 & i66 & i67 & i68 & i69 & i70 & i71 & i72 & i73 & i74 & i75 & i76 & i77 & i78 & i79 & i80 '& i81 & i82 & i83 & i84 & i85 & i86 & i87 & i88 & i89 & i90 & i91 & i92 & i93 & i94 & i95 & i96 & i97 & i98 & i99 & i100 & i101 & i102 & i103 & i104 & i105 & i106 & i107 & i108 & i109 & i110 & i111 & i112 & i113 & i114 & i115 & i116 & i117 & i118 & i119 & i120 & i121 & i122 & i123 & i124 & i125
Rs.Open Sorgu, Con, 1, 1
S = "Select f1,f2,f3,f4,f5,f6,f7 FROM [Sayfa1$A2:DU] where 1=1  " & i81 & i82 & i83 & i84 & i85 & i86 & i87 & i88 & i89 & i90 & i91 & i92 & i93 & i94 & i95 & i96 & i97 & i98 & i99 & i100 & i101 & i102 & i103 & i104 & i105 & i106 & i107 & i108 & i109 & i110 & i111 & i112 & i113 & i114 & i115 & i116 & i117 & i118 & i119 & i120 & i121 & i122 & i123 & i124 & i125
Rss.Open S, Con, 1, 1
If Rs.RecordCount > 0 Then
Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1).CopyFromRecordset Rs
End If
If Rss.RecordCount > 0 Then
Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1).CopyFromRecordset Rss
End If
Rs.Close: Rss.Close
Con.Close
Next Dosyalar
Set Con = Nothing: Set Rs = Nothing: Set Fso = Nothing: Set Klasor = Nothing
Set Dosyalar = Nothing: Dosya = vbNullString
MsgBox "İşlem başarılı", vbInformation + vbMsgBoxRtlReading, "www.ExcelDepo.com"
End Sub

Deneyin
 

Ekli dosyalar

Oyla 0 Olumsuz oyla
Feyzullah hocam teşekkür ediyorum. Şu şekilde hata veriyor.

x.webp


xx.webp
 
Oyla 0 Olumsuz oyla
Sn. @gicimi kodlarda bir revizyon yaptım. Güncel kod aşağıdaki gibidir. Dosya yoluna dikkat edelim Masa üstünde "Kapalı Dosyalar" klasöründe olmalı dosyalar.

VBA: 
Sub ExcelDepo()
' www.ExcelDepo.com metehan8001****
Dim Con As Object, Rs As Object, Rss As Object, Fso As Object, Klasor As Object, Dosyalar As Object, ws As Object
Dim Sorgu As String, Dosya As String, Desk As String, Dosya_Yolu As String
Set Con = CreateObject("AdoDb.Connection")
Set Rs = CreateObject("AdoDb.RecordSet")
Set Rss = CreateObject("AdoDb.RecordSet")
Set Fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("WScript.Shell")
Desk = ws.SpecialFolders("Desktop")
Dosya_Yolu = Desk & "\Kapalı Dosyalar\"
Set Klasor = Fso.GetFolder(Dosya_Yolu)
Range("A3:DU65536").ClearContents
For Each Dosyalar In Klasor.Files
if left(dosyalar.name,1) <> "~" then
Con.Open "provider=Microsoft.Ace.OleDb.12.0;Data Source=" & Dosyalar & _
";Extended Properties=""Excel 12.0;HDR=no"""
a = Range("A1").Value
i = "'" & a & "'"
i1 = " and (f1) like " & i & "": i2 = " or (f2) like " & i & "": i3 = " or (f3)like " & i & "":
i4 = " or f4 like " & i & "": i5 = " or (f5) like " & i & "": i6 = " or (f6) like " & i & "":
i7 = " or f7 like " & i & "": i8 = " or (f8) like " & i & "": i9 = " or f9 like " & i & "":
i10 = " or f10 like " & i & "": i11 = " or (f11) like " & i & "": i12 = " or f12 like " & i & "":
i13 = " or f13 like " & i & "": i14 = " or f14 like " & i & "": i15 = " or f15 like " & i & "":
i16 = " or f16 like " & i & "": i17 = " or f17 like " & i & "": i18 = " or f18 like " & i & "":
i19 = " or f19 like " & i & "": i20 = " or f20 like " & i & "": i21 = " or f21 like " & i & "":
i22 = " or f22 like " & i & "": i23 = " or f23 like " & i & "": i24 = " or f24 like " & i & "":
i25 = " or f25 like " & i & "": i26 = " or f26 like " & i & "": i27 = " or f27 like " & i & "":
i28 = " or f28 like " & i & "": i29 = " or f29 like " & i & "": i30 = " or f30 like " & i & "":
i31 = " or f31 like " & i & "": i32 = " or f32 like " & i & "": i33 = " or f33 like " & i & "":
i34 = " or f34 like " & i & "": i35 = " or f35 like " & i & "": i36 = " or f36 like " & i & "":
i37 = " or f37 like " & i & "": i38 = " or f38 like " & i & "": i39 = " or f39 like " & i & "":
i40 = " or f40 like " & i & "": i41 = " or f41 like " & i & "": i42 = " or f42 like " & i & "":
i43 = " or f43 like " & i & "": i44 = " or f44 like " & i & "": i45 = " or f45 like " & i & "":
i46 = " or f46 like " & i & "": i47 = " or f47 like " & i & "": i48 = " or f48 like " & i & "":
i49 = " or f49 like " & i & "": i50 = " or f50 like " & i & "": i51 = " or f51 like " & i & "":
i52 = " or f52 like " & i & "": i53 = " or f53 like " & i & "": i54 = " or f54 like " & i & "":
i55 = " or f55 like " & i & "": i56 = " or f56 like " & i & "": i57 = " or f57 like " & i & "":
i58 = " or f58 like " & i & "": i59 = " or f59 like " & i & "": i60 = " or f60 like " & i & "":
i61 = " or f61 like " & i & "": i62 = " or f62 like " & i & "": i63 = " or f63 like " & i & "":
i64 = " or f64 like " & i & "": i65 = " or f65 like " & i & "": i66 = " or f66 like " & i & "":
i67 = " or f67 like " & i & "": i68 = " or f68 like " & i & "": i69 = " or f69 like " & i & "":
i70 = " or f70 like " & i & "": i71 = " or f71 like " & i & "": i72 = " or f72 like " & i & "":
i73 = " or f73 like " & i & "": i74 = " or f74 like " & i & "": i75 = " or f75 like " & i & "":
i76 = " or f76 like " & i & "": i77 = " or f77 like " & i & "": i78 = " or f78 like " & i & "":
i79 = " or f79 like " & i & "": i80 = " or f80 like " & i & "":
i81 = " and f81 like " & i & "":
i82 = " or f82 like " & i & "": i83 = " or f83 like " & i & "": i84 = " or f84 like " & i & "":
i85 = " or f85 like " & i & "": i86 = " or f86 like " & i & "": i87 = " or f87 like " & i & "":
i88 = " or f88 like " & i & "": i89 = " or f89 like " & i & "": i90 = " or f90 like " & i & "":
i91 = " or f91 like " & i & "": i92 = " or f92 like " & i & "": i93 = " or f93 like " & i & "":
i94 = " or f94 like " & i & "": i95 = " or f95 like " & i & "": i96 = " or f96 like " & i & "":
i97 = " or f97 like " & i & "": i98 = " or f98 like " & i & "": i99 = " or f99 like " & i & "":
i100 = " or f100 like " & i & "": i101 = " or f101 like " & i & "": i102 = " or f102 like " & i & "":
i103 = " or f103 like " & i & "": i104 = " or f104 like " & i & "": i105 = " or f105 like " & i & "":
i106 = " or f106 like " & i & "": i107 = " or f107 like " & i & "": i108 = " or f108 like " & i & "":
i109 = " or f109 like " & i & "": i110 = " or f110 like " & i & "": i111 = " or f111 like " & i & "":
i112 = " or f112 like " & i & "": i113 = " or f113 like " & i & "": i114 = " or f114 like " & i & "":
i115 = " or f115 like " & i & "": i116 = " or f116 like " & i & "": i117 = " or f117 like " & i & "":
i118 = " or f118 like " & i & "": i119 = " or f119 like " & i & "": i120 = " or f120 like " & i & "":
i121 = " or f121 like " & i & "": i122 = " or f122 like " & i & "": i123 = " or f123 like " & i & "":
i124 = " or f124 like " & i & "": i125 = " or f125 like " & i & "":
Sorgu = "Select f1,f2,f3,f4,f5,f6,f7 FROM [Sayfa1$A2:DU] where 1=1  " & i1 & i2 & i3 & i4 & i5 & i6 & i7 & i8 & i9 & i10 & i11 & i12 & i13 & i14 & i15 & i16 & i17 & i18 & i19 & i20 & i21 & i22 & i23 & i24 & i25 & i26 & i27 & i28 & i29 & i30 & i31 & i32 & i33 & i34 & i35 & i36 & i37 & i38 & i39 & i40 & i41 & i42 & i43 & i44 & i45 & i46 & i47 & i48 & i49 & i50 & i51 & i52 & i53 & i54 & i55 & i56 & i57 & i58 & i59 & i60 & i61 & i62 & i63 & i64 & i65 & i66 & i67 & i68 & i69 & i70 & i71 & i72 & i73 & i74 & i75 & i76 & i77 & i78 & i79 & i80 '& i81 & i82 & i83 & i84 & i85 & i86 & i87 & i88 & i89 & i90 & i91 & i92 & i93 & i94 & i95 & i96 & i97 & i98 & i99 & i100 & i101 & i102 & i103 & i104 & i105 & i106 & i107 & i108 & i109 & i110 & i111 & i112 & i113 & i114 & i115 & i116 & i117 & i118 & i119 & i120 & i121 & i122 & i123 & i124 & i125
Rs.Open Sorgu, Con, 1, 1
S = "Select f1,f2,f3,f4,f5,f6,f7 FROM [Sayfa1$A2:DU] where 1=1  " & i81 & i82 & i83 & i84 & i85 & i86 & i87 & i88 & i89 & i90 & i91 & i92 & i93 & i94 & i95 & i96 & i97 & i98 & i99 & i100 & i101 & i102 & i103 & i104 & i105 & i106 & i107 & i108 & i109 & i110 & i111 & i112 & i113 & i114 & i115 & i116 & i117 & i118 & i119 & i120 & i121 & i122 & i123 & i124 & i125
Rss.Open S, Con, 1, 1
If Rs.RecordCount > 0 Then
Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1).CopyFromRecordset Rs
End If
If Rss.RecordCount > 0 Then
Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1).CopyFromRecordset Rss
End If
Rs.Close: Rss.Close
Con.Close
end if
Next Dosyalar
Set Con = Nothing: Set Rs = Nothing: Set Fso = Nothing: Set Klasor = Nothing
Set Dosyalar = Nothing: Dosya = vbNullString
MsgBox "İşlem başarılı", vbInformation + vbMsgBoxRtlReading, "www.ExcelDepo.com"
End Sub
 
Oyla 1 Olumsuz oyla
Çözüm
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
Benzer Konular Popüler İçerikler Daha Fazlası
Geri
Üst Alt