Girdiğim verileri koşula göre başka sayfaya atma

[emrebengul]

merhaba üstadlar
excelde girdiğim verileri koşula göre başka sayfaya aktarmasını istiyorum. Örneğin B2 hücresi kadın ise SPSSKADIN sayfasına, erkek ise SPSSERKEK sayfasına atmasını istiyorum. Destekleriniz için çok teşekkür ederim.


tmak istiyorum. Ben biraz gelebildim fakat hata veriyor destek olur musunuz?

 

[Necdet]

Merhaba,
Klasik Aktarma Makrosu, Oku ve Yaz, yavaştır ama anlaşılması kolaydır

Public Sub Aktar()

Dim eRow As Long, _
    kRow As Long, _
    i    As Long, _
    adt  As Integer

'Genel Açıklama :
'Sayfa2 Sheets("veri"),
'Sayfa3 Sheets("SPSSERKEK"),
'Sayfa4 Sheets("SPSSKADIN") anlamında Yani Sayfa İndisi kullanılmıştır

Application.ScreenUpdating = False

Sayfa3.Range("A1").CurrentRegion.ClearContents
Sayfa4.Range("A1").CurrentRegion.ClearContents

Sayfa2.Range("A1:H1").Copy Sayfa3.Range("A1")
Sayfa2.Range("A1:H1").Copy Sayfa4.Range("A1")

eRow = 1: kRow = 1

For i = 2 To Sayfa2.Cells(Rows.Count, "A").End(3).Row
    If Sayfa2.Cells(i, "B") = "ERKEK" Then
        eRow = eRow + 1
        Sayfa2.Range("A" & i & ":H" & i).Copy Sayfa3.Range("A" & eRow)
    ElseIf Sayfa2.Cells(i, "B") = "KADIN" Then
        kRow = kRow + 1
        Sayfa2.Range("A" & i & ":H" & i).Copy Sayfa4.Range("A" & kRow)
    Else
        adt = adt + 1
    End If
Next i

If adt > 0 Then MsgBox "Belirsiz Olan " & adt & " Adet Kayıt AKTARILMADI"
Application.ScreenUpdating = True
    
End Sub

 

[emrebengul]

Teşekkürler Necdet Bey

 

[emrebengul]

Peki Necdet Bey bunada bir bakma şansınız var mı?
verileri alt alt alta girip hepsini tek bir sayfaya atmasını istiyorum.

 

[Necdet]

Merhaba,
Dener misiniz? Kaç sütun sayısına bakılmaksızın aktarır.

Sub Aktar()

Dim col As Integer
Dim lrow As Long
Dim icol As Integer

col = Sayfa2.Cells(1, Columns.Count).End(1).Column
lrow = Sayfa3.Cells(Rows.Count, 1).End(3).Row

For icol = 2 To col
    lrow = lrow + 1
    For i = 1 To 8
        Sayfa3.Cells(lrow, i) = Sayfa2.Cells(i, icol)
    Next i
Next icol

MsgBox "İşlem Tamamdır..."

End Sub

 

[emrebengul]

teşekkürler üstadım