Tabloya İki koşula Göre Veri Getirmek

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
834
Excel Vers. ve Dili
Office 2016 TR
Merhaba,

Koli içeriğine göre bir ürüne ait birden fazla üretim reçeteleri mevcut.
Reçeteler revizyon kodlarına göre ayrılmıştır. ( R01, R02, R03, …..)
Örnek dosyada tablo sayfası B Sütununda bulunan kod ile D Sütununda bulanan Revizyon koduna göre F,G,H,I,J Sütnlarını Liste sayfasından getirmek istiyorum.

Yardımlarınız için teşekkür ederim.
 

Ekli dosyalar

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Formülle nasıl olur bilemiyorum ama makroyla isterseniz aşağıdaki kodları bir modüle kopyalayıp deneyiniz:

PHP:
Sub aktar()
Set s1 = Sheets("Liste")
Set s2 = Sheets("Tablo")
sonliste = s1.Cells(Rows.Count, "A").End(3).Row
sontablo = s2.Cells(Rows.Count, "B").End(3).Row
If sontablo > 2 Then
    Application.ScreenUpdating = False
        s2.Range("F3:K" & sontablo).ClearContents
        Set con = VBA.CreateObject("adodb.Connection")
        con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
        For i = 3 To sontablo Step 9
            If WorksheetFunction.CountIfs(s1.Range("A1:A" & sonliste), s2.Cells(i, "D"), s1.Range("C1:C" & sonliste), s2.Cells(i, "B")) > 8 Then
                s2.Cells(i, "K") = "Bu üründen 8'den fazla kayıt mevcut olduğundan işlem yapılmadı!"
            ElseIf WorksheetFunction.CountIfs(s1.Range("A1:A" & sonliste), s2.Cells(i, "D"), s1.Range("C1:C" & sonliste), s2.Cells(i, "B")) > 0 Then
                sorgu = "select [Malzeme Kodu],[Malzeme Açıklaması],[Malzeme Açıklaması 2],[Miktar],[Birimi] from [Liste$] where " & _
                        "[Revizyon Kodu]='" & s2.Cells(i, "D") & "' and [ÜRÜN REÇETESİ KOD ANA KAYIT]='" & s2.Cells(i, "B") & "'"
                Set rs = con.Execute(sorgu)
                s2.Cells(i, "F").CopyFromRecordset rs
            End If
        Next
    Application.ScreenUpdating = True
End If
End Sub
 

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
834
Excel Vers. ve Dili
Office 2016 TR
Formülle nasıl olur bilemiyorum ama makroyla isterseniz aşağıdaki kodları bir modüle kopyalayıp deneyiniz:
Hocam gayet güzel olmuş emeğinize sağlık. Bazı ürünlerde satır sayısı 1 veya 2 artmakta. Onun için burayı değiştirdim oldu.

Kod:
For i = 3 To sontablo Step 10
            If WorksheetFunction.CountIfs(s1.Range("A1:A" & sonliste), s2.Cells(i, "D"), s1.Range("C1:C" & sonliste), s2.Cells(i, "B")) > 9 Then
                s2.Cells(i, "K") = "Bu üründen 10'den fazla kayıt mevcut olduğundan işlem yapılmadı!"
Teşekkür ederim.
 

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
834
Excel Vers. ve Dili
Office 2016 TR
Formülle nasıl olur bilemiyorum ama makroyla isterseniz aşağıdaki kodları bir modüle kopyalayıp deneyiniz:
Hocam, bulut klasörüne kaydettim ama çalışmadı. Bulut klasöründen masaüstüne kısa yol ekledim yine çalışmadı. Ekli resimdeki hatayı veriyor.
 

Ekli dosyalar

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Bazı ürünlerde satır sayısı fazla olursa belirttiğiniz düzeltme işe yaramaz bence. Çünkü düzeltme her seçenek için geçerli olur. Benim verdiğim kodda her 9 satırda bir kontrol yapıyordu, siz ise 10 satırda bir kontrol yaptırıyorsunuz. Verileriniz eğer düzensiz ise yani aralarında belirli bir satır farkı yoksa aşağıdaki kod iş görebilir. Ancak iş görebilmesi için B ve D sütunlarındaki verilerinize göre tablo sayfanızda verileri düzgün yerleştirmiş olmanız gerekir:

PHP:
Sub aktar()
Set s1 = Sheets("Liste")
Set s2 = Sheets("Tablo")
sonliste = s1.Cells(Rows.Count, "A").End(3).Row
sontablo = s2.Cells(Rows.Count, "F").End(3).Row
s2.Activate
If sontablo > 2 Then
    Application.ScreenUpdating = False
        s2.Range("F3:J" & sontablo).ClearContents
        Set con = VBA.CreateObject("adodb.Connection")
        con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
        For i = 3 To sontablo
            If s2.Cells(i, "B") <> "" And s2.Cells(i, "D") <> "" And s2.Cells(i, "B") <> s2.Cells(i - 1, "B") Then
                If WorksheetFunction.CountIfs(s1.Range("A1:A" & sonliste), s2.Cells(i, "D"), s1.Range("C1:C" & sonliste), s2.Cells(i, "B")) > 0 Then
                    sorgu = "select [Malzeme Kodu],[Malzeme Açıklaması],[Malzeme Açıklaması 2],[Miktar],[Birimi] from [Liste$] where " & _
                            "[Revizyon Kodu]='" & s2.Cells(i, "D") & "' and [ÜRÜN REÇETESİ KOD ANA KAYIT]='" & s2.Cells(i, "B") & "'"
                    Set rs = con.Execute(sorgu)
                    s2.Cells(i, "F").CopyFromRecordset rs
                End If
            End If
        Next
    Application.ScreenUpdating = True
End If
End Sub
 

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Hocam, bulut klasörüne kaydettim ama çalışmadı. Bulut klasöründen masaüstüne kısa yol ekledim yine çalışmadı. Ekli resimdeki hatayı veriyor.
Neden bahsettiğinizi anlayamadım maalesef.
 

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
834
Excel Vers. ve Dili
Office 2016 TR
Neden bahsettiğinizi anlayamadım maalesef.
Merhaba Hocam, Outlook OneDrive e yükleyip bilgisayarımdan çalıştırınca o hatayı verdi. Dosya direk bilgisayarda kayıtlı olunca sorun yok.

Verilerim düzenli ve en fazla 10 satır farkı vardır.

İlk verdiğiniz kodlar işimi çok rahat görüyor. Her ürüne ait revizyon kodlarını yazmak reçetelerin çok olmasından dolayı karışıklık oldu.
Kodlarda değişiklik yapmaya çalıştım. Tek sorguya (B Sütunu) dayalı hale getirmek istedim ancak, bir ürüne ait sadece bir revizyonu getirebildim, yapamadım. Değiştirdiğim kodlar bu şekilde.
Tek sorguya dayalı olarak çalıştırmak mümkün mü ?

Kod:
Sub aktar()
Set s1 = Sheets("Liste")
Set s2 = Sheets("Tablo")
sonliste = s1.Cells(Rows.Count, "A").End(3).Row
sontablo = s2.Cells(Rows.Count, "B").End(3).Row
If sontablo > 2 Then
    Application.ScreenUpdating = False
        s2.Range("C3:K" & sontablo).ClearContents
        Set con = VBA.CreateObject("adodb.Connection")
        con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
        For i = 3 To sontablo Step 10
            If WorksheetFunction.CountIfs(s1.Range("C1:C" & sonliste), s2.Cells(i, "B")) > 9 Then
                s2.Cells(i, "K") = "Bu üründen 10'den fazla kayıt mevcut olduğundan işlem yapılmadı!"
            ElseIf WorksheetFunction.CountIfs(s1.Range("C1:C" & sonliste), s2.Cells(i, "B")) > 0 Then
                sorgu = "select [ÜRÜN REÇETESİ AÇIKLAMA ANA KAYIT],[Revizyon Kodu],[Revizyon Açıklaması],[Malzeme Kodu],[Malzeme Açıklaması],[Malzeme Açıklaması 2],[Miktar],[Birimi] from [Liste$] where " & _
                        "[ÜRÜN REÇETESİ KOD ANA KAYIT]='" & s2.Cells(i, "B") & "'"
                Set rs = con.Execute(sorgu)
                s2.Cells(i, "C").CopyFromRecordset rs
            End If
        Next
    Application.ScreenUpdating = True
End If
End Sub
 

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Son dosyanıza göre ekli dosyadaki kod daha uygun oldu. Kodun bu halinde Tablo sayfasına herhangi bir veri girmeniz gerekmiyor. Sayfa2 yardımcı sayfa olarak kullanılıp ana maddeler bu sayfa listeleniyor. Sonra da bu listedeki her veri için tablo sayfasında bir blok oluşturuluyor ve biçimlendiriliyor. Ekli dosyayı inceleyiniz.

Not: Dosyanın son hali #15 nolu mesajdadır.
 
Son düzenleme:

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
834
Excel Vers. ve Dili
Office 2016 TR
Son dosyanıza göre ekli dosyadaki kod daha uygun oldu. Kodun bu halinde Tablo sayfasına herhangi bir veri girmeniz gerekmiyor. Sayfa2 yardımcı sayfa olarak kullanılıp ana maddeler bu sayfa listeleniyor. Sonra da bu listedeki her veri için tablo sayfasında bir blok oluşturuluyor ve biçimlendiriliyor. Ekli dosyayı inceleyiniz.
Hocam, öncelikle yardımlarınız için teşekkür ederim. Dosya bu hali ile daha güel olmuş ancak butona bastığımda Sayfa2ye veri geliyor ama tablo sayfasına gelmedi.
 

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Hocam, öncelikle yardımlarınız için teşekkür ederim. Dosya bu hali ile daha güel olmuş ancak butona bastığımda Sayfa2ye veri geliyor ama tablo sayfasına gelmedi.
Dosyayı hatalı haliyle paylaşır mısınız?
 

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Nasıl oldu anlamadım (muhtemelen dosyanın son halini bilgisayara kaydetmeden buraya yüklemişim) belirttiğiniz gibi oluyor. Ekli dosyayı inceleyin.
 

Ekli dosyalar

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
834
Excel Vers. ve Dili
Office 2016 TR
Nasıl oldu anlamadım (muhtemelen dosyanın son halini bilgisayara kaydetmeden buraya yüklemişim) belirttiğiniz gibi oluyor. Ekli dosyayı inceleyin.
Hocam, emeğinize sağlık, mükemmel olmuş. Teşekkür ederim.
 
Üst