Soru Kapalı Dosyadan Kritere göre Veri Almak

[ormann]

Günaydın;
İki adet dosyam var biri Ebat listesi ve Veri alınacak dosya. Alınacak kriterleri aşağıda belirttim. Veri alınacak dosyadaki sayfa adı veri girişi sayfasında P8 hücresindeki isimle aranacak. Ayrıca veri alınacak dosyayı Dosya seç işlemi ile alınacak. Dosya seçildikten sonra kritere göre veri alınacak ve veri alma işlemi bittikten sonra .... adet veri alma işlemi tamamlanmıştır diye uyarı verecek .Biraz karışık gibi inşallah olu.Saygılar

İndir EBAT LİSTESİ

Dosyayı indir EBAT LİSTESİ

dosya.co

İndir VERİ ALANACAK DOSYA

Dosyayı indir VERİ ALANACAK DOSYA

dosya.co

* İstif sayfasındaki E1 hücresindeki veri veri girişi sayfasında J10 hücresine alınacak.
* İstif sayfasındaki A2:A hücresindeki veriler(İstif No) aynı ve tek olduğundan veri girişi sayfasında J8 hücresine alınacak.
* İstif Sayfasındaki B2:B hücresindeki veriler (çaplar)sırasına göre (Küçükten büyüğe doğru) Veri Girişi Sayfasında F20:F69 hücresine alınacak
* İstif Sayfasındaki C2:C hücresindeki veriler (Boylar) veri girişi sayfasında G18:V18 hücre sine alınacak.
* İstif sayfasındaki D2:d hücresindeki veriler (Adet) veri girişi sayfasında G20:V69 hücre aralığındaki çap ve boyların karşılığına gelecek yerlere alınacak.

 

[ormann]

Arkadaşlar rica etsem konuya yardımcı olur musunuz ?

 

[Korhan Ayhan]

VERİ ALINACAK DOSYA'da başka istif numaraları olacak mı?

 

[ormann]

Olmayacak

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Verileri_Aktar()
    Dim Dosya As Variant, Baglanti As Object, Sorgu As String
    Dim Kayit_Seti As Object, K1 As Workbook, S1 As Worksheet
    Dim Veri_A As Range, Veri_B As Range, Sayfa_Adi As String
    Dim Veri As Variant, Zaman As Double, X As Byte, Say As Long
    Dim Veri_Adresi As Variant, Hedef_Adres As Variant
    
    Dosya = Application.GetOpenFilename("Excel Dosyaları (*.xl*),*.xl*", , "Hedef Dosyayı Seçin")
    If Dosya = False Then Exit Sub
    
    Zaman = Timer
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("VERİ GİRİŞİ")
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
    S1.Range("J8:M8,J10:M10,F20:V69,G18:V18").ClearContents
    
    Veri_Adresi = Array("E1:E1", "A2:A2", "B2:B1000", "C2:C1000")
    
    Hedef_Adres = Array("J10", "J8", "F20", "G18")
    
    Sayfa_Adi = S1.Range("P8").Value
        
    For X = 0 To UBound(Veri_Adresi)
        Select Case X
            Case 2
                Sorgu = "Select Distinct * From [" & Sayfa_Adi & "$" & Veri_Adresi(X) & "]"
                Set Kayit_Seti = Baglanti.Execute(Sorgu)
                Veri = Kayit_Seti.GetRows(Kayit_Seti.RecordCount)
                S1.Range(Hedef_Adres(X)).Resize(UBound(Veri, 2) + 1) = Application.Transpose(Veri)
                Say = Say + UBound(Veri, 2) + 1
            Case 3
                Sorgu = "Select Distinct * From [" & Sayfa_Adi & "$" & Veri_Adresi(X) & "]"
                Set Kayit_Seti = Baglanti.Execute(Sorgu)
                Veri = Kayit_Seti.GetRows(Kayit_Seti.RecordCount)
                S1.Range(Hedef_Adres(X)).Resize(1, UBound(Veri, 2) + 1) = Veri
                Say = Say + UBound(Veri, 2) + 1
            Case Else
                Sorgu = "Select * From [" & Sayfa_Adi & "$" & Veri_Adresi(X) & "]"
                Set Kayit_Seti = Baglanti.Execute(Sorgu)
                S1.Range(Hedef_Adres(X)).CopyFromRecordset Kayit_Seti
                Say = Say + 1
        End Select
    Next
    
    For Each Veri_A In S1.Range("F20:F69")
        If Veri_A.Value <> "" Then
            For Each Veri_B In S1.Range("G18:V18")
                If Veri_B.Value <> "" Then
                    Sorgu = "Select F4 From [" & Sayfa_Adi & "$] Where F2 = " & _
                            Replace(Veri_A.Value, ",", ".") & " And F3 = " & Replace(Veri_B.Value, ",", ".")
                    Set Kayit_Seti = Baglanti.Execute(Sorgu)
                    S1.Cells(Veri_A.Row, Veri_B.Column).CopyFromRecordset Kayit_Seti
                    If S1.Cells(Veri_A.Row, Veri_B.Column) <> "" Then Say = Say + 1
                End If
            Next
        End If
    Next
    
    Kayit_Seti.Close
    Baglanti.Close
    
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    Set S1 = Nothing
    Set K1 = Nothing
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "Toplam " & Format(Say, "#,##0") & " adet veri alındı." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[ormann]

Korhan bey iyi geceler ;
aşağıdaki makroda hata veriyor.

If Veri_B.Value <> "" Then

 

[ormann]

Korhan bey asıl dosyama uyarladım.Fakat Hata veriyor. Dosyalar ektedir

İndir Veri Alanacak dosya

Dosyayı indir Veri Alanacak dosya

dosya.co

İndir EBAT LİSTESİ 2020

Dosyayı indir EBAT LİSTESİ 2020

dosya.co

 

[Korhan Ayhan]

Üstteki mesajımda ki kodu revize ettim. Tekrar deneyiniz.

 

[ormann]

Korhan bey hocam günaydın.
Son yapmış olduğunuz makroyu dosyama uyarladım.Fakat verileri alırken G18: V18 hücre aralığındaki boylar ile, G20:V69 hücre aralığındaki adetlerin çoğunu almıyor.Genelde G,H sutunundaki verileri alıyor.

 

[Korhan Ayhan]

Kodu tekrar revize ettim. Deneyiniz.

Toplam ADET olarak son paylaştığınız dosyada 856 olarak görünüyor. Son kodla bu değere ulaştım.

Sizde deneyip sonucu bildirirseniz sevinirim.

 

[ormann]

Korhan bey çok teşekkür ederim. Şu an için bir sıkıntı yok. Tüm hücreleri doldurdum. Aktarıp geri aldım. Veriler birebir tuttu. Eğer sizi uğraştırmayacaksa en son şu kadar sürede işlem süresi tamamlandının yanında birde aynı
MsgBox'un içerisine .... adet veri alındı da ekleme durumunuz olabilir mi?

 

[Korhan Ayhan]

Alınan veri adedi bilgisi de üstteki mesajımda ki koda ilave edildi. Deneyiniz.

 

[bordo6181]

Korhan bey dosya seç yapmadan benzer bir konuyu nasıl yapabiliriz.

Bağlantılı excellerde koşullu veri çekmek

Merhabalar Öncelikle forumda çok yardımsever insan var herkese teşekkür ederim ve @hmtstc 'nin sayesinde mükemmel bir excel programına sahip oldum. Ancak exceli hem kendim öğrenmek için hemde bazı yerlerini değiştirmek amacıyla kurcalarken bozdum. Mantık olarak şöyle çalışan 5 excelim var...

www.excel.web.tr

 

[ormann]

Korhan bey yardımlarınız için çok çok teşekkür ederim.