Liste Oluşturma

[veyselk]

Arkadaşlar merhaba!
Ekte gönderdiğim dosya için yardımlarınızı bekliyorum.
Sayfa1 deki seçime göre sayfa 2 de liste oluşturmak istiyorum. Detaylı açıklama dosya içerisinde var.

 

[N.Ziya Hiçdurmaz]

yanıt

Sub aktar()
Set s1 = Sheets("sayfa1")
Set s2 = Sheets("sayfa2")
s2.Range("b2:h1000").Clear
For sut1 = 2 To s1.[a65536].End(3).Row
For sut2 = 2 To s2.[a65536].End(3).Row
If Range("a" & sut1) = Range("a" & sut2) Then
s2.Range("b" & sut2) = s1.Range("b" & sut1).Value
s2.Range("c" & sut2) = s1.Range("e" & sut1).Value
End If
Next
Next
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[AS3434]

Seçtiğiniz sütunları aktarmak isterseniz.

Sub sütunaktar()
Application.ScreenUpdating = False
Set f1 = Sheets("Sayfa1")
Set f2 = Sheets("Sayfa2")
f2.[a:e].Clear
For y = 1 To 5
If Cells(1, y) = "x" Then
Columns(y).Copy
t = t + 1
f2.Columns(t).PasteSpecial Paste:=xlAll
End If
Next
Application.CutCopyMode = False
f2.Select
Rows(1).Delete
[a2].Select
End Sub

 

[veyselk]

Arkadaşlar Teşekkür ederim. İstediğim Oldu ancak Sayın As3434 ' bir şey sormak istiyorum Aynı Seçimi satırlar İçinde yapabilir miyiz?

 

[AS3434]

Evet yapabilirsiniz.

Sub sütunaktar()
Application.ScreenUpdating = False
Set f1 = Sheets("Sayfa1")
Set f2 = Sheets("Sayfa2")
f2.[a:e].Clear
For y = 1 To 5
If Cells(1, y) = "x" Then
Columns(y).Copy
t = t + 1
f2.Columns(t).PasteSpecial Paste:=xlAll
End If
Next
Application.CutCopyMode = False
f2.Select
[a:a].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Rows(1).Delete
Columns(1).Delete
[a2].Select
End Sub

 

[veyselk]

Teşekkür Ederim. yardımlarınızı her zaman bekliyoruz.

 

[AS3434]

İşinize yaradığına sevindim.

Yalnız bir hata yapmışım. 1 sütun ilave edince kodda değişiklik yapmamışım.

Koddaki

For y = 1 To 5

satırını

For y = 1 To 6

olarak değiştirin.

 

[Necdet]

Merhaba,

Alternatif olarak

İster kolonları, isterse satırları Ctrl tuşuna basılı tutarak seçin ve makroyu çalıştırın. Kolonları seçtiyseniz kolonlar, satırları seçtiyseniz satırlar aktarılır.

Sub SecVeAktar()
    Sheets("Sayfa2").[A1:E100].Clear 
    Selection.Copy
    Sheets("Sayfa2").Select
    Range("A1").Select
    ActiveSheet.Paste
End Sub