dolu hücreleri kopyalayıp yapıştırma

[Kablelvuku]

1. sayfada b2:b655 arasında bulunan dolu hücreleri kopyalayıp 2. sayfaya c3 hücresine transpose olarak nasıl kopyalatabiliriz

 

[Orion1]

Buyurun.

Sub aktar59()
Dim sh As Worksheet, i As Integer, liste(), a As Long
Set sh = Sheets("Sayfa2")
Sheets("Sayfa1").Select
sh.Range(sh.Cells(3, "C"), sh.Cells(3, Columns.Count)).ClearContents
ReDim liste(1 To 1, 1 To 655)
For i = 2 To 655
    If Cells(i, "B").Value <> "" Then
        a = a + 1
        liste(1, a) = Cells(i, "B").Value
    End If
Next i
ReDim Preserve liste(1 To 1, 1 To a)
sh.Range("C3").Resize(1, a) = liste
sh.Select
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[SCOCUK]

ActiveSheet.Unprotect "123" ' Bu kod ile sayfa korumasını kaldırıyorum

Aşağıdaki kod ile sayfa korumasını şifresiz olarak ve "Satırları Biçimlendir Seçeneği seçili bir şekilde yeniden koruyorum ama bu işlem şifresiz oluyor

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingRows:=True

Ben ise aşağıdakine benzer bir şekilde "satırları biçimlendir" aktif olacak şekilde sayfayı şifre ile korumaya çalışıyorum ama olmuyor

ActiveSheet.Protect "123" DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingRows:=True

Kısaca
AllowFormattingRows:=True
ActiveSheet.Protect "123"

kodlarını (özelliğini) birlikte kullanmak istiyorum

 

[SCOCUK]

ActiveSheet.Unprotect "123"


ActiveSheet.Protect "123", _
AllowFormattingRows:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True

Yukadıdaki kodlar ile işlemler oluyor arkadaşlar bilginize