Süzülen Verileri Aktarırken Gizli Sütunlardakilerinide Aktarmak

[mustafa1205]

Sub Aktar2()

Sheets("Sayfa1").Select
ActiveSheet.Range("$A$1:$cz$5000").AutoFilter Field:=1, Criteria1:="marmara"

Sheets("Sayfa2").Cells.ClearContents
Range("A1").CurrentRegion.Copy Sheets("Sayfa2").Range("A1")

End Sub


Yukarıdaki kodlar ile Sayfa 1 deki verilerimi Sayfa 2 ye aktarabiliyorum. Ancak Sayfa 1 de gizlenmiş olan veri sütunları olduğu zaman onları aktarmıyor. Gizli olsun olmasın tüm sütunlardaki verileri aktarabilmek için aktarabilmesi için nasıl bir revizyon yapmamız gerekir acaba ?

 

[Necdet]

Merhaba,
Bir milyon sütunu yerine 7-8 sütun örnek dosya olsa görsel olarak kodun çalışmasını daha rahat izleme şansı olurdu.
Dosyanızı 8 sütuna indirdim, bunun da 4 sütununu gizledim ve sizin kodunuzu çalıştırdım, gizlenen sütunları a aktardı.
Ben bir sorun göremedim kodlarınızda.
Ya da sorunuzu anlamadım.

 

[mustafa1205]

Hocam sanırım benim dosya üzerinde anlatamam dan kaynaklanan bir sorun oldu. Ekte bulunan dosyamda yeşil boyalı alandaki sütunları gizleyince verileri 2'nci sayfaya boyalı alanlar hariç aktarıyor. Bir milyon satır hususunda kusura bakmayın. Deneme yapıyordum ne kadar sütunu aktarabiliyor diye. Ondan kalmış???

 

[Necdet]

Bir deneyin bakalım. Başka bir yöntem var mı bilemiyorum.

Sub Aktar()

    Sheets("Sayfa1").Select
    Cells.EntireColumn.Hidden = False
    ActiveSheet.Range("$A$1:$cz$5000").AutoFilter Field:=1, Criteria1:="marmara"

    Sheets("Sayfa2").Cells.ClearContents

    Sheets("Sayfa1").Range("A1").CurrentRegion.Copy
    Sheets("Sayfa2").Range("A1").PasteSpecial (xlPasteValues)

End Sub

 

[mustafa1205]

Hocam ilginiz için çok teşekkür ederim. Gizli sütunları açarak verileri aktarmayı bende denedim. O zaman bir sorun olmuyor. Yaklaşık 120 sütundan oluşan bir veri sayfam var ve aralarda rastgele (5-7-16-22-23-45-46-47-54-55-77-78-79'ncu ve buna benzer) sütunlar gizli olduğundan hepsini açıp sonra tekrar tek tek gizleme ihtiyacı olduğundan bu soruyu sormuştum. Çok sağolun Hocam. İlgilenmeniz bile yeter.

 

[Necdet]

Merhaba,

Deneyiniz.

Sub Aktar()

    Dim i As Long
    Dim arr As Variant
    
    Application.ScreenUpdating = False
    
    Sheets("Sayfa1").Select
    
    arr = Range("A1").CurrentRegion.Value
    
    For i = 1 To UBound(arr, 2)
        arr(1, i) = Cells(1, i).EntireColumn.Hidden
    Next i
    
    Cells.EntireColumn.Hidden = False
    ActiveSheet.Range("$A$1:$cz$5000").AutoFilter Field:=1, Criteria1:="marmara"

    Sheets("Sayfa2").Cells.ClearContents

    Sheets("Sayfa1").Range("A1").CurrentRegion.Copy
    Sheets("Sayfa2").Range("A1").PasteSpecial (xlPasteValues)
    
    For i = 1 To UBound(arr, 2)
        If arr(1, i) = True Then Cells(1, i).EntireColumn.Hidden = True
    Next i

    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
    
End Sub

 

[mustafa1205]

Hocam gayet güzel bir şekilde çalıştı. Elinize emeğinize sağlık. Çok teşekkür ederim...

 

[Necdet]

Rica ederim, güle güle kullanınız.