sayfa 1 i sayfa 2 ye aktarma

[seranonet]

ekde açıklama yaptım

 

[Orion1]

Aktar butonuna basınız.
Sayfa2 de a sütununa koşullu biçimlendirme uygulandı.Mükerre kayıtlar kırmızı ile renkleniyor.
Ekli dosyayı inceleyiniz.

Sub aktar()
Sheets("Sayfa2").Range("A1:A65536").ClearContents
ReDim myarr(1 To 1, 1 To 1)
For i = 1 To Sheets("Sayfa1").Cells(65536, "A").End(xlUp).Row
    If Cells(i, "A").Value <> "" Then
        a = a + 1
        ReDim Preserve myarr(1 To 1, 1 To a)
        myarr(1, a) = Cells(i, "A").Value
    End If
Next
Sheets("Sayfa2").Select
Application.ScreenUpdating = False
If a > 1 Then
    [A1].Resize(a, 1) = Application.Transpose(myarr)
End If
Application.ScreenUpdating = True
MsgBox "İşlem Tamam..!!", vbOKOnly + vbInformation, "AKARMA"
End Sub

 

[DeliBalta58]

Sayın Uzmanım. Beni de bir yükten kurtardınız. Bu örneği çok işe yarayacak
Kendime göre uyarlayabilmek için Kodlar hakkında bilgi vermeniz mümkünmü acaba?
bildiklerimi yazıyorum.

Sheets("Sayfa2").Range("A1:A65536").ClearContents

Sayfa2 A1-A65536 arası temizleniyor.

Application.ScreenUpdating = False

Sayfa geçişlerini ekanda gösterme
Bunlar ne anlamda acaba?

ReDim myarr(1 To 1, 1 To 1)

For i = 1 To Sheets("Sayfa1").Cells(65536, "A").End(xlUp).Row

    If Cells(i, "A").Value <> "" Then
        a = a + 1
        ReDim Preserve myarr(1 To 1, 1 To a)
        myarr(1, a) = Cells(i, "A").Value
    End If
Next
Sheets("Sayfa2").Select
Application.ScreenUpdating = False
If a > 1 Then
    [A1].Resize(a, 1) = Application.Transpose(myarr)
End If
Application.ScreenUpdating = True

Teşekkürler

 

[Orion1]

Sayın Uzmanım. Beni de bir yükten kurtardınız. Bu örneği çok işe yarayacak
Kendime göre uyarlayabilmek için Kodlar hakkında bilgi vermeniz mümkünmü acaba?
Teşekkürler

Sayfa1'in a sütunu son dolu satıra kadar döngüye girilerek
boş olmayan hücreler redim ile tanıttığımız dizi değişkeni içersine alınıyor,ve sayfa2'de a2 hücresinden itibaren resize ile listeleniyor.

 

[DeliBalta58]

teşekkürler

 

[Orion1]

teşekkürler

Rica ederim.