koşula göre arama yapma

Korhan Ayhan · 1 Haziran 2020

Senaryoyu kastetmiştim.

Neleri nerede arıyorsunuz?

20'şer sayfa var demişsiniz. Sayfa isimlerini sabit mi? Her dosyada aynı mı?

Not: Mesajınızdaki tüm kelimeleri büyük harfle yazmayınız. Profilinizdeki ofis sürümü bilgisini lütfen güncelleyiniz.

garatemur · 1 Haziran 2020

Korhan Ayhan' Alıntı:
Senaryoyu kastetmiştim.

Neleri nerede arıyorsunuz?

20'şer sayfa var demişsiniz. Sayfa isimlerini sabit mi? Her dosyada aynı mı?

Not: Mesajınızdaki tüm kelimeleri büyük harfle yazmayınız. Profilinizdeki ofis sürümü bilgisini lütfen güncelleyiniz.

1.syfa 1 den 19 noya kadar sayfa numaralanmış sayfa isimleri sabit 1-19 arası. 2 kitap da 20-38 arası sıralı sayfa isimleri sabit bu sayfalardaki s S sütunu prog fiş için sayfasındaki a2-ve aşağısındaki değere eşit ise prgr fiş için sayfasınkai çizelgede istenen değerler sıralanacak progr sayfası "brüt kg" boş KALACAK, "O" sütunu diğer sayfalardaki v sütununa TEKABÜL EDİYOR , "p" sütunu diğer sayfalardaki "ab" sütununa tekabül ediyor.

Korhan Ayhan · 1 Haziran 2020

İ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

garatemur · 1 Haziran 2020

sürüm 14.0.6023.1000(32-bit) kod çalışıyor fakat sadece üretim1 den veri çekiyor , üretim 2 den veri çekmiyor ve şu uyarı çıkıyo "system error &h80040E10(-2147217904)

garatemur · 1 Haziran 2020

garatemur' Alıntı:
sürüm 14.0.6023.1000(32-bit) kod çalışıyor fakat sadece üretim1 den veri çekiyor , üretim 2 den veri çekmiyor ve şu uyarı çıkıyo "system error &h80040E10(-2147217904)

Dil türkçe

garatemur · 1 Haziran 2020

garatemur' Alıntı:
sürüm 14.0.6023.1000(32-bit) kod çalışıyor fakat sadece üretim1 den veri çekiyor , üretim 2 den veri çekmiyor ve şu uyarı çıkıyo "system error &h80040E10(-2147217904)

bu alana birden fazla ktap eklemem gerekiyor üretim1 ve 2 kitplarını "Dosya = Dir(Yol & "üretim1-2020.xlsm")"

Korhan Ayhan · 2 Haziran 2020

Klasör altındaki tüm dosyalardan uygun verileri alır. Bir değişiklik yapmanıza gerek yok.

garatemur · 2 Haziran 2020

Korhan Ayhan' Alıntı:
Klasör altındaki tüm dosyalardan uygun verileri alır. Bir değişiklik yapmanıza gerek yok.

günaydın Korhan bey . Maalesef makro çalışmıyor ""system error &h80040E10(-2147217904) " hatası veriyor.

Korhan Ayhan · 2 Haziran 2020

Benimle paylaştığınız dosyalarda deneyip sonucu bildirir misiniz?

garatemur · 2 Haziran 2020

onu da denedim aynı sonuç

garatemur · 2 Haziran 2020

yalnız şöyle de bir durum var benim atladığım size attığım 2 üretim dosya uzantısı xlsx, bunların orjinalleri xlsm

Korhan Ayhan · 2 Haziran 2020

Dosyaların uzantısı farketmez.

(xls, xlsx, xlsm) uzantılarını denediğimde bende sorun çıkarmadan çalıştı.

Sizin asıl dosyalarınızda uyumsuz bir veri tipi olabilir.

garatemur · 2 Haziran 2020

sürüm bu bilgisayarda faarklı acaba ondan mı hata veriyor sürüm microsoft excel 2016 mso (16.0.4266.1001) 64 bit

çok üzgünüm sizi çok oyaladım.

Korhan Ayhan · 2 Haziran 2020

Birde bu kodu deneyin.

C++:

Option Explicit

Sub Klasordeki_Excel_Dosyalarindan_Veri_Al()
    Dim S1 As Worksheet, Son As Long, Veri As Variant, X As Integer
    Dim Yol As String, Dosya As String, Tum_Sayfalar As Object
    Dim Sayfa As Worksheet, Satir As Long, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
   
    Yol = ThisWorkbook.Path & Application.PathSeparator
   
    Set S1 = ThisWorkbook.Sheets("FİŞ İÇİN")
   
    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 = Application.Transpose(S1.Range("A2:A" & Son).Value)
   
    For X = LBound(Veri) To UBound(Veri)
        Veri(X) = CStr(Veri(X))
    Next
   
    Dosya = Dir(Yol & "*.xls*")
   
    While Dosya <> ""
        If Dosya <> ThisWorkbook.Name Then
            Set Tum_Sayfalar = GetObject(Yol & Dosya).Worksheets
            For Each Sayfa In Tum_Sayfalar
                Sayfa.Range("A1:AO" & Sayfa.Rows.Count).AutoFilter Field:=19, Criteria1:=Veri, Operator:=xlFilterValues
                Son = Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row
                If Son >= 2 Then
                    Satir = S1.Cells(S1.Rows.Count, 2).End(3).Row + 1
                    Sayfa.Range("A2:D" & Son).SpecialCells(xlCellTypeVisible).Copy
                    S1.Range("B" & Satir).PasteSpecial xlValues
                    Sayfa.Range("E2:F" & Son).SpecialCells(xlCellTypeVisible).Copy
                    S1.Range("G" & Satir).PasteSpecial xlValues
                    Sayfa.Range("H2:H" & Son).SpecialCells(xlCellTypeVisible).Copy
                    S1.Range("I" & Satir).PasteSpecial xlValues
                    Sayfa.Range("K2:L" & Son).SpecialCells(xlCellTypeVisible).Copy
                    S1.Range("J" & Satir).PasteSpecial xlValues
                    Sayfa.Range("Q2:S" & Son).SpecialCells(xlCellTypeVisible).Copy
                    S1.Range("L" & Satir).PasteSpecial xlValues
                    Sayfa.Range("V2:V" & Son).SpecialCells(xlCellTypeVisible).Copy
                    S1.Range("O" & Satir).PasteSpecial xlValues
                    Sayfa.Range("AB2:AB" & Son).SpecialCells(xlCellTypeVisible).Copy
                    S1.Range("P" & Satir).PasteSpecial xlValues
                    Application.CutCopyMode = False
                End If
            Next
            Workbooks(Dosya).Close 0
        End If
        Dosya = Dir
    Wend
           
    Set Tum_Sayfalar = Nothing
    Set S1 = 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

garatemur · 2 Haziran 2020

maalesef bu da çalışmadı. her seferinde 2 defa pano üstündeki bilgiler çok büyük diyor. 2 satırlık veri de 2000 satırlık veride aynı zaman diliminde gerçekleşiyor.ve verileri fiş için sayfasına gelmiyor. ilk seferde çalıştı sonra çalışmadı

Korhan Ayhan · 2 Haziran 2020

#34 nolu mesajımdaki koda küçük bir ekleme yaptım. Tekrar deneyiniz.

Bu da olmazsa başka bir alternatif deneriz.

garatemur · 2 Haziran 2020

Korhan Ayhan' Alıntı:
#34 nolu mesajımdaki koda küçük bir ekleme yaptım. Tekrar deneyiniz.

Bu da olmazsa başka bir alternatif deneriz.

34 nolu mesajınızdaki kodu alıp denedim aynı sonucu aldım maalesef

Korhan Ayhan · 2 Haziran 2020

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

garatemur · 2 Haziran 2020

"Microsoft Visual Basic For Aplications" Owerflow hatası veriyor

Korhan Ayhan · 2 Haziran 2020

Veri dosyalarınızda kaç satır veri var?

koşula göre arama yapma

Korhan Ayhan

Administrator

garatemur

Korhan Ayhan

Administrator

garatemur

garatemur

garatemur

Korhan Ayhan

Administrator

garatemur

Korhan Ayhan

Administrator

garatemur

garatemur

Korhan Ayhan

Administrator

garatemur

Korhan Ayhan

Administrator

garatemur

Korhan Ayhan

Administrator

garatemur

Korhan Ayhan

Administrator

garatemur

Korhan Ayhan

Administrator