DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub Aktar()
Dim i As Long, _
sh2 As Worksheet
Set sh2 = Sheets("2")
i = sh2.Cells(Rows.Count, "A").End(3).Row + 1
If Application.WorksheetFunction.CountA(Range("B2:B28")) < 1 Then
MsgBox "BOŞ KAYIT.....", vbCritical
Exit Sub
End If
Application.ScreenUpdating = True
Range("B1:B28").Copy
sh2.Range("A" & i).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("B2:B28").ClearContents
Range("B1") = Range("B1") + 1
Range("B2").Activate
Application.ScreenUpdating = True
End Sub
yardımlarınız için çok teşekkürler sağolunn mukemmel bir yardımdıı bizim için
sn: necdet yeşertener ben çalışma.rar dosyasını açamıyorum neden