Datadaki Verileri Kişilere Göre Dağıt

[baydeniro]

Merhaba arkadaşlar. Veriler datasındaki karışı ksırada bulunan kişilerin görevlerini diğer sayfaya gruplayarak aktarmak mümkün mü ? Örnek dosya ekte.

 

[İhsan Tank]

Merhaba arkadaşlar. Veriler datasındaki karışı ksırada bulunan kişilerin görevlerini diğer sayfaya gruplayarak aktarmak mümkün mü ? Örnek dosya ekte.

merhaba
boş module

Option Explicit
Sub aktar()
Dim ts, kaplan, trabzonspor
ts = MsgBox("Verileri Çıkarıyorum", vbYesNo, "Onay")
If ts = vbNo Then Exit Sub
Application.ScreenUpdating = False
Sheets("RAPOR").Range("A2:L65536").ClearContents
For trabzonspor = 2 To Sheets("RAPOR").Cells(1, 256).End(xlToLeft).Column
kaplan = 2
For ts = 3 To Sheets("GENEL").Cells(65536, "A").End(xlUp).Row
If Sheets("GENEL").Cells(ts, "A") = Sheets("RAPOR").Cells(1, trabzonspor) Then
Sheets("RAPOR").Cells(kaplan, trabzonspor) = Sheets("GENEL").Cells(ts, "C")
kaplan = kaplan + 1
End If
Next
Next
Application.ScreenUpdating = True
MsgBox "Verileri Çıkarttım", vbInformation, "Bitiş"
End Sub

bu kodu kopyalayın ve deneyin

 

[N.Ziya Hiçdurmaz]

yanıt

Alternatif

Sub adres()
Dim sat As Integer, s As Integer

Sayfa5.Range("b2:l" & Rows.Count).ClearContents
    For sut = 2 To Sayfa5.Cells(1, 256).End(xlToLeft).Column
    s = 2
    For sat = 3 To Sayfa2.Cells(Rows.Count, "a").End(xlUp).Row
        If Sayfa2.Cells(sat, "a") Like Sayfa5.Cells(1, sut) Then
            Sayfa2.Cells(sat, "c").Copy Sayfa5.Cells(s, sut)
                s = s + 1
        End If
    Next
    Next
End Sub

 

[baydeniro]

Çok teşekkür ederim sayın İhsan Tank, mübarek Kadir Gecesi Allah sizden razı olsun, sağlıcakla kalın.

 

[baydeniro]

Sayın Niyazi Hiçdurmaz ilginize teşekkür ederim. Kod 4. satırsa "sut" aşamasında duruyor.

 

[İhsan Tank]

Çok teşekkür ederim sayın İhsan Tank, mübarek Kadir Gecesi Allah sizden razı olsun, sağlıcakla kalın.

rica ederim
Allah Hepimizden Razı Olsun
:yazici: