veri aktarma koduna koşul eklenmesi

[kemal turan]

Sn.Üstadlar,
Aşağıdaki kod ,
cari sahifesinde filtre yapılmışsa çalışsın yoksa çalışmasın şeklinde koşul revize edecek kod eklemesi yapılmasına ihtiyacım var.
Yardımlarınız için teşekkürler

Sub deneme()
Set s1 = Sheets("CARİ")
Set s2 = Sheets("KASA")

For i = 2 To s1.Range("A65536").End(3).Row
If s1.Cells(i, 1).EntireRow.Hidden = False Then
SONSTR = s2.Range("c65536").End(3).Row + 1
s2.Cells(SONSTR, 7).Value = s1.Cells(i, 2).Value
s2.Cells(SONSTR, 5).Value = s1.Cells(i, 4).Value
s2.Cells(SONSTR, 8).Value = s1.Cells(i, 7).Value
s2.Cells(SONSTR, 3).Value = s1.Cells(i, 9).Value
s2.Cells(SONSTR, 4).Value = s1.Cells(i, 11).Value
s2.Cells(SONSTR, 6).Value = s1.Cells(i, 12).Value

End If
Next
Sheets("kasa").Select
MsgBox "Kayıt işlemi tamamlanmıştır.", , "istikbal"


End Sub

 

[Husgvarna]

Sn.Üstadlar,
Aşağıdaki kod ,
cari sahifesinde filtre yapılmışsa çalışsın yoksa çalışmasın şeklinde koşul revize edecek kod eklemesi yapılmasına ihtiyacım var.
Yardımlarınız için teşekkürler

Sub deneme()
Set s1 = Sheets("CARİ")
Set s2 = Sheets("KASA")
For a = 1 To Sheets("CARİ").Cells(65000, 1).End(xlUp).Row
If s1.Cells(a, 1).EntireRow.Hidden = True Then c = c + 1
Next
If c = 0 Then Exit Sub
For i = 2 To s1.Range("A65536").End(3).Row
SONSTR = s2.Range("c65536").End(3).Row + 1
if s1.Cells(i, 1).EntireRow.Hidden = False Then

s2.Cells(SONSTR, 7).Value = s1.Cells(i, 2).Value
s2.Cells(SONSTR, 5).Value = s1.Cells(i, 4).Value
s2.Cells(SONSTR, 8).Value = s1.Cells(i, 7).Value
s2.Cells(SONSTR, 3).Value = s1.Cells(i, 9).Value
s2.Cells(SONSTR, 4).Value = s1.Cells(i, 11).Value
s2.Cells(SONSTR, 6).Value = s1.Cells(i, 12).Value

End If
Next
Sheets("kasa").Select
MsgBox "Kayıt işlemi tamamlanmıştır.", , "istikbal"


End Sub

Alıntıdaki gibi olabilir.

 

[kemal turan]

Sn.Husgvarna
Emeğiniz için çok teşekkür ederim.
Kodunuz ihtiyacımı çok güzel karşıladı.
Ben kodunuza "aktarma yapılsınmı? " msgbox ekleyebildim!!
Hoş güzelde hayır desemde beni dinlemiyor
Filtre yapılmamışsa msgbox "filtre yapınız." uyarısı verdirebilirmiyiz.
Selametle kalınız.
Sub deneme()
Set s1 = Sheets("CARİ")
Set s2 = Sheets("KASA")
For a = 1 To Sheets("CARİ").Cells(65000, 1).End(xlUp).Row
If s1.Cells(a, 1).EntireRow.Hidden = True Then c = c + 1
Next
MsgBox "KAYIT YAPILSIN MI.", 3, "istikbal"

If c = 0 Then Exit Sub
For i = 2 To s1.Range("A65536").End(3).Row
SONSTR = s2.Range("c65536").End(3).Row + 1
If s1.Cells(i, 1).EntireRow.Hidden = False Then

s2.Cells(SONSTR, 7).Value = s1.Cells(i, 2).Value
s2.Cells(SONSTR, 5).Value = s1.Cells(i, 4).Value
s2.Cells(SONSTR, 8).Value = s1.Cells(i, 7).Value
s2.Cells(SONSTR, 3).Value = s1.Cells(i, 9).Value
s2.Cells(SONSTR, 4).Value = s1.Cells(i, 11).Value
s2.Cells(SONSTR, 6).Value = s1.Cells(i, 12).Value

End If
Next
Sheets("kasa").Select
MsgBox "Kayıt işlemi tamamlanmıştır.", , "istikbal"


End Sub

 

[Husgvarna]

Filtre yapılmamışsa msgbox "filtre yapınız." uyarısı verdirebilirmiyiz.

Aşağıdaki bölümü ekleyin.

If s1.Cells(a, 1).EntireRow.Hidden = True Then c = c + 1
Next
[COLOR="Red"]If c = 0 Then
MsgBox "FİLTRELEME YAPINIZ."
 Exit Sub
 End If
m = MsgBox("KAYIT YAPILSIN MI.", vbYesNo, "istikbal")
If m <> vbYes Then Exit Sub[/COLOR]

For i = 2 To s1.Range("A65536").End(3).Row

 

[kemal turan]

Sn.Husgvarna
Çok teşekkür ederim.Tam istediğim gibi.Emeğinize sağlık.
Selametle kalınız.