• DİKKAT

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

koşula göre arama yapma

ve çalışırken açık olan kitabı kapatıyor kapatmaması gerekir. çalışma kitapları birbirine bağlantılı dönüp diğer kitaba bakmam gerekiyor her zAMAN
 
#38 nolu mesajımdaki kodu revize ettim. Tekrar deneyiniz.

Yine olmazsa mahsuru yoksa asıl dosyalarıızı bana özel mesaj yoluyla iletin bende deneme yapayım.
 
Aldığınız dosyaları benimle paylaşırsanız inceleyip hatayı bulma şansım olabilir.
 
Korhan Ayhan' Alıntı:
İlk olarak profilinizde kullandığınız excel sürümünü ve dilini belirtmenizde fayda var.

Aşağıdaki kodu deneyiniz.

Bütün dosyalarınız aynı klasör altında olması gerekiyor. Eğer farklı klasörler altında olacaksa kod içindeki "YOL =" ile başlayan satırı kendinize göre düzenlersiniz.

Veri alınacak dosyaların açık olmasına gerek yoktur.

C++: 
Option Explicit

Sub Klasordeki_Excel_Dosyalarindan_Veri_Al()
    Dim Baglanti As Object, Kayit_Seti As Object, WB_Catalog As Object, Sayfa As Object
    Dim Sorgu As String, Yol As String, Dosya As String, Veri As Range, Zaman As Double
  
    Zaman = Timer
  
    Application.ScreenUpdating = False
  
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set WB_Catalog = CreateObject("AdoX.Catalog")
    Set Sayfa = CreateObject("AdoX.Table")
  
    Yol = ThisWorkbook.Path & Application.PathSeparator
  
    Range("B7:S" & Rows.Count).ClearContents
  
    Dosya = Dir(Yol & "*.xls*")
  
    While Dosya <> ""
        If Dosya <> ThisWorkbook.Name Then
            Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            Yol & Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
          
            WB_Catalog.ActiveConnection = Baglanti
          
            For Each Sayfa In WB_Catalog.Tables
                If Replace(Sayfa.Name, "'", "") Like "*" & "$" Then
                    For Each Veri In Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
                        If Veri.Value <> "" Then
                            Sorgu = "Select F1,F2,F3,F4,Null,F5,F6,F8,F11,F12,F17,F18,F19,F22,F28 From [" & Sayfa.Name & "] Where F19 Is Not Null And F19 =" & Veri.Value
                            Set Kayit_Seti = Baglanti.Execute(Sorgu)
                            Cells(Rows.Count, 2).End(3)(2, 1).CopyFromRecordset Kayit_Seti
                        End If
                    Next
                End If
            Next
            Baglanti.Close
        End If
        Dosya = Dir
    Wend
  
    Set Baglanti = Nothing
    Set WB_Catalog = Nothing
    Set Sayfa = Nothing
    Set Kayit_Seti = Nothing
  
    Application.ScreenUpdating = True
  
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
Genişletmek için tıkla ...
Merhaba.18.satırın boş olmaması koşulunu bu makroya nasıl ekleyebilirim ?
 
Sizden son bir ricam daha olacak, çektiğim veriler fiş için sayfası içinde iken bu veriler üzerinde sadece roling numaralarını değiştirmeden diğer bilgilerde değişiklik yapıp bu bilgileri makro yardımız ile üretim1 ve üretim 2 deki eski verilerin yerine nasıl atayabilirim ?
 
Korhan Ayhan' Alıntı:
Birde bu kodu deneyiniz.

C++: 
Option Explicit

Sub Klasordeki_Excel_Dosyalarindan_Veri_Al()
    Dim S1 As Worksheet, Son As Long, Veri As Variant, X As Long
    Dim Kriter As Object, Yol As String, Dosya As String, Tum_Sayfalar As Object
    Dim Sayfa As Worksheet, Say As Long, Zaman As Double
  
    Zaman = Timer
  
    Application.ScreenUpdating = False
  
    Yol = ThisWorkbook.Path & Application.PathSeparator
  
    Set S1 = ThisWorkbook.Sheets("FİŞ İÇİN")
    Set Kriter = CreateObject("Scripting.Dictionary")
  
    S1.Range("B7:S" & S1.Rows.Count).ClearContents
  
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son = 2 Then Son = 3
    Veri = S1.Range("A2:A" & Son).Value
  
    For X = LBound(Veri) To UBound(Veri)
        Kriter.Item(Veri(X, 1)) = 1
    Next
  
    ReDim Liste(1 To Rows.Count, 1 To 15)
  
    Dosya = Dir(Yol & "*.xls*")
  
    While Dosya <> ""
        If Dosya <> ThisWorkbook.Name Then
            Set Tum_Sayfalar = GetObject(Yol & Dosya).Worksheets
            For Each Sayfa In Tum_Sayfalar
                Son = Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row
                Veri = Sayfa.Range("A2:AO" & Son)
                For X = LBound(Veri) To UBound(Veri)
                    If Kriter.Exists(Veri(X, 19)) Then
                        Say = Say + 1
                        Liste(Say, 1) = Veri(X, 1)
                        Liste(Say, 2) = Veri(X, 2)
                        Liste(Say, 3) = Veri(X, 3)
                        Liste(Say, 4) = Veri(X, 4)
                        Liste(Say, 5) = Empty
                        Liste(Say, 6) = Veri(X, 5)
                        Liste(Say, 7) = Veri(X, 6)
                        Liste(Say, 8) = Veri(X, 8)
                        Liste(Say, 9) = Veri(X, 11)
                        Liste(Say, 10) = Veri(X, 12)
                        Liste(Say, 11) = Veri(X, 17)
                        Liste(Say, 12) = Veri(X, 18)
                        Liste(Say, 13) = Veri(X, 19)
                        Liste(Say, 14) = Veri(X, 22)
                        Liste(Say, 15) = Veri(X, 28)
                    End If
                Next
            Next
            Workbooks(Dosya).Close 0
        End If
        Dosya = Dir
    Wend
   
    If Say > 0 Then S1.Range("B7").Resize(Say, 15) = Liste
   
    Set Tum_Sayfalar = Nothing
    Set S1 = Nothing
    Set Kriter = Nothing
          
    Application.ScreenUpdating = True
  
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
Genişletmek için tıkla ...
bu kod sağlıklı çalıştı
 
Son mesajınızdan sonra kodun çalışmasında bir sorun kaldı mı?

Süre olarak avantaj sağladı mı?
 
kodun çalışmasında bir sorun kalmadı süre olarak oldukça fazla avantaj sağladı çok teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst