İkili Eğer Koşulu ve Yazdırma

[kumandur]

Merhabalar ekte gönderğim tablonun ilk sekmesi Özet Tablo , ikinci sekmesi kronik

Yapmak istediğim Kronik tabloda , Cari Kodu Cari Adı ve Borç Bakiye kısmına , özel tablodaki Kesilen fatura "0" ve kırmızı renkli alacak bakiye "0" olanları; Kronik bölümündeki Cari Kodu Cari Adı ve Cari Bakiye bölümlerine karşılıklarını yazdırmak. Ek olarak Kırmızı bölümdeki borç bakiye sütununda "0" mevcutsa onu da yazdırmasın.

İlginizi ve yardımlarını rica ederim.

Teşekkür ederim.

 

[Mahir64]

Merhaba,

özel tablodaki Kesilen fatura "0" ve kırmızı renkli alacak bakiye "0" olanları; Kronik bölümündeki Cari Kodu Cari Adı ve Cari Bakiye bölümlerine karşılıklarını yazdırmak.

demişsiniz ama

Ek olarak Kırmızı bölümdeki borç bakiye sütununda "0" mevcutsa onu da yazdırmasın.

0 olanları yazdırmasın demişsiniz. Hangi işlem yapılacak?

 

[YUSUF44]

Aşağıdaki makroyu bir modüle kopyalayıp deneyiniz:

Sub aktar()
Set s1 = Sheets("Özet Tablo")
Set s2 = Sheets("Kronik")
son = WorksheetFunction.Max(3, s1.Cells(Rows.Count, "A").End(3).Row)
eski = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "A").End(3).Row)
uyar = MsgBox("Kronik sayfasındaki eski veriler silinsin mi?", vbYesNo)
If uyar = vbYes Then
    s2.Range("A2:C" & eski).ClearContents
End If
yeni = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "A").End(3).Row + 1)
Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""

sorgu = "select F1,F2,F3 from[" & s1.Name & "$A3:K" & son & "] where F11=0 and F4=0 and F3<>0"
Set rs = con.Execute(sorgu)
s2.[A2].CopyFromRecordset rs

End Sub

 

[kumandur]

Aşağıdaki makroyu bir modüle kopyalayıp deneyiniz:

Sub aktar()
Set s1 = Sheets("Özet Tablo")
Set s2 = Sheets("Kronik")
son = WorksheetFunction.Max(3, s1.Cells(Rows.Count, "A").End(3).Row)
eski = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "A").End(3).Row)
uyar = MsgBox("Kronik sayfasındaki eski veriler silinsin mi?", vbYesNo)
If uyar = vbYes Then
    s2.Range("A2:C" & eski).ClearContents
End If
yeni = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "A").End(3).Row + 1)
Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""

sorgu = "select F1,F2,F3 from[" & s1.Name & "$A3:K" & son & "] where F11=0 and F4=0 and F3<>0"
Set rs = con.Execute(sorgu)
s2.[A2].CopyFromRecordset rs

End Sub

Teşekkür ederim,çalışıyor, kusura bakmazsanız bunu bir tuşla veya otomatik çalışmasını nasıl yapabiliriz.

 

[YUSUF44]

Excel dosyanıza bir düğme/resim/şekil/nesne ekleyin. Eklediğinize sağ tıklayıp makro ata deyin. Listeden makroyu seçip işlemi tamamlayın. Dosyayı makro içerebilen Excel dosyası olarak kaydedin.