Boş yere kadar Kopyala -Özel yapıştır

[quesh]

Merhabalar arkadaşlar
sayfa1den sayfa10'a kadar 10 sayfam olduğunu varsayalım.

her sayfa için;

4.satırdan başla;
boş satırı gördüğün yere kadar aşağı in ve tüm satırları kopyala, ve özel yapıştır-Değerleri.

bu döngüyü nasıl uygulayabilirim ?

Teşekkür ederim.

 

[uzmanamele]

merhaba

sanırım aynı yere kopyalamak istiyorsunuz.
aşağıdaki kodlar işinizi görür mü?

Sub kopyala_yapistir_1()
Application.ScreenUpdating = False
For i = 1 To Worksheets.Count
Sheets(i).Select
ss = Sheets(i).Range("a65536").End(3).Row
    Rows("1:" & ss).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

veya

Sub kopyala_yapistir_2()
Application.ScreenUpdating = False
For i = 1 To Worksheets.Count
Sheets(i).Select
Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("a1").Select
Next
Application.ScreenUpdating = True
End Sub

 

[quesh]

Teşekkür ederim. 34.sütuna kadar kopyalama işlemi yapacağımı söylemeyi unutmuşum bu arada. ben de şöyle bir çözüm buldum. alternatif olsun

i = 4
Do Until Cells(i, 2) = ""
i = i + 1
Loop
Range(Cells(4, 2), Cells(i - 1, 34)).Select
Selection.copy
Selection.PasteSpecial Paste:=xlPasteValues