Seçilen hücreleri toplu aktarma

[bono]

Arkadaşlar

sheet1 de yer alan bilgileri AKTARILAN sheetine bazı kriterler doğrultusunda aktarmaya çalışıyorum. Makroya baktığınızda anlayacağınız gibi hangi hücrede duruyorsam onu ilk kolon olarak AKTARILAN sheetine atıyor ve sonrasında ona göre sayıp belli kolonları bulup sıralıyor.

Ancak çalıştığımız dosya yüklü ve sheet1 den bir çok satırı AKTARILAN sheetine aktarmamız gerekiyor. Benim makromda hangi hücre üzerindeysen sadece onu aktarıyor. Bir ikincisi için yine makroyu kullanmak gerekiyor. Oysa tüm aktaracağım bilgileri tarayarak hepsini bu dosyaya yönlendirme şansım olsaydı çok daha kolay olacaktı. Taranan bilgiler filter dan belli kriterlere göre çekilmiş satırlardan oluşacak. Yani sıralı satırlarda değil. Elbette bunu başaramadım. Yardımcı olursanız sevinirim.

Sub YUKLE()
Dim hucre As Range
Dim say As Integer


Sheets("AKTARILAN").Select
say = WorksheetFunction.CountA(Range("a1:a20"))
say = say + 1
Sheets("Sheet1").Select
Set hucre = Selection

Sheets("AKTARILAN").Cells(say, 1).Value = Selection.Value

i = 1


Sheets("AKTARILAN").Cells(say, i + 1).Value = Selection.Offset(0, 4).Value


Sheets("AKTARILAN").Cells(say, i + 2).Value = Selection.Offset(0, 2).Value


Sheets("AKTARILAN").Cells(say, i + 3).Value = Selection.Offset(0, 3).Value


Sheets("AKTARILAN").Cells(say, i + 4).Value = Selection.Offset(0, 7).Value

Sheets("AKTARILAN").Cells(say, i + 5).Value = Selection.Offset(0, 12).Value


Sheets("AKTARILAN").Cells(say, i + 6).Value = Selection.Offset(0, 14).Value

Sheets("AKTARILAN").Cells(say, i + 7).Value = Selection.Offset(0, 15).Value
Sheets("AKTARILAN").Cells(say, i + 8).Value = Selection.Offset(0, 16).Value
Sheets("AKTARILAN").Cells(say, i + 9).Value = Selection.Offset(0, 17).Value
Sheets("AKTARILAN").Cells(say, i + 10).Value = Selection.Offset(0, 20).Value

Sheets("AKTARILAN").Cells(say, i + 11).Value = Selection.Offset(0, 29).Value
Sheets("AKTARILAN").Cells(say, i + 12).Value = Selection.Offset(0, 30).Value
Sheets("AKTARILAN").Cells(say, i + 13).Value = Selection.Offset(0, 31).Value


ActiveWorkbook.Sheets("Sheet1").Select


End Sub

 

[Korhan Ayhan]

Selamlar,

Örnek dosya eklerseniz çözüme kolaylıkla ulaşabilirsiniz. Hangi verilerin nereye aktarılacağınıda açıklarsanız cevap verecek arkadaşlara kolaylık sağlamış olursunuz.

 

[bono]

Örnek bir dosya hazırladım ve içerisinde makroyuda bu örnek dosyada çalışabilecek halde koydum. Yardımlarınız için şimdiden teşekkürler

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub AKTAR()
    Dim Hücre As Range
    Dim Satır As Long
    Satır = 2
    Sheets("AKTARILAN").Range("A2:G65536").ClearContents
    For Each Hücre In Selection
    If Hücre.RowHeight <> 0 Then
    With Sheets("AKTARILAN")
        .Cells(Satır, 1) = Cells(Hücre.Row, 1)
        .Cells(Satır, 2) = Cells(Hücre.Row, 4)
        .Cells(Satır, 3) = Cells(Hücre.Row, 6)
        .Cells(Satır, 4) = Cells(Hücre.Row, 7)
        .Cells(Satır, 5) = Cells(Hücre.Row, 8)
        .Cells(Satır, 6) = Cells(Hücre.Row, 12)
        .Cells(Satır, 7) = Cells(Hücre.Row, 13)
    End With
    Satır = Satır + 1
    End If
    Next
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[parametre]

calısma guzel olmuş eline saglık

 

[bono]

Korhan bey elinize sağlık çok güzel olmuş. Yardımların için teşekkürler