DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub KAYIT()
Set S1 = Sheets("kayıt giriş")
Set S2 = Sheets("İŞLETME DEFTERİ")
If WorksheetFunction.CountIf([C5:C65536], ">0") = 0 Then
MsgBox "Kayıt edilecek veri bulunamamıştır.", vbExclamation, "Dikkat !"
Exit Sub: End If
SATIR = S2.[B65536].End(3).Row + 1
S1.Range("C5:M" & S1.[C65536].End(3).Row).Copy S2.Range("B" & SATIR)
If S1.[B5] <> "" Then
Set S3 = Sheets(S1.[B5].Text)
SATIR = S3.[A65536].End(3).Row + 1
S1.Range("C5:M" & S1.[C65536].End(3).Row).Copy S3.Range("A" & SATIR)
End If
Set S1 = Nothing
Set S2 = Nothing
Set S3 = Nothing
MsgBox "Kayıt işlemi tamamlanmıştır.", vbInformation
End Sub
Selamlar,
Aşağıdaki kodu denermisiniz.
Not: Sayfa isimlerinizin sonunda boşluklar bırakmışsınız onları kaldırırsanız kod sorunsuz çalışacaktır.
Kod:Sub KAYIT() Set S1 = Sheets("kayıt giriş") Set S2 = Sheets("İŞLETME DEFTERİ") If WorksheetFunction.CountIf([C5:C65536], ">0") = 0 Then MsgBox "Kayıt edilecek veri bulunamamıştır.", vbExclamation, "Dikkat !" Exit Sub: End If SATIR = S2.[B65536].End(3).Row + 1 S1.Range("C5:M" & S1.[C65536].End(3).Row).Copy S2.Range("B" & SATIR) If S1.[B5] <> "" Then Set S3 = Sheets(S1.[B5].Text) SATIR = S3.[A65536].End(3).Row + 1 S1.Range("C5:M" & S1.[C65536].End(3).Row).Copy S3.Range("A" & SATIR) End If Set S1 = Nothing Set S2 = Nothing Set S3 = Nothing MsgBox "Kayıt işlemi tamamlanmıştır.", vbInformation End Sub