Puantaj yatay verileri dikey alma

A

alirizapekbilir

Katılım
11 Şubat 2016
Mesajlar
199
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
15-02-2021
Örnek dosyamda puantaj sayfasındaki verileri sayfa1 e dikey aktarmak istiyorum. 1 kişi için örnek yaptım ama uzun sürecek. makro yada fonksiyonla daha hızlı nasıl çözebilirim. Yardımlarınızı bekliyorum teşekkürler. 1 kişi için 30 satır 150 kişilik hesabımla 4500 satır :)
 

Ekli dosyalar

A

alirizapekbilir

Katılım
11 Şubat 2016
Mesajlar
199
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
15-02-2021
Çok teşekkürler beni büyük zahmetten kurtardınız.
 
A

alirizapekbilir

Katılım
11 Şubat 2016
Mesajlar
199
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
15-02-2021
Üstad bi ricam olacak bu makroyla tüm tabloyu aktarıyoruz kriteri sadece "F" olan kodları aktaracak şekilde puantajı revize etme şansımız varmı acaba. Böylekikle dosyam boşuna şişmemiş olur.
 
Z

Ziynettin

Destek Ekibi
Destek Ekibi
Katılım
18 Nisan 2008
Mesajlar
1,105
Excel Vers. ve Dili
office2010
Kod: 
Sub test()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Puantaj")
Set s2 = Sheets("Sayfa1")
son = s1.Cells(Rows.Count, "J").End(3).Row
a = s1.Range("K4:AQ" & son).Value
ReDim b(1 To Rows.Count, 1 To 4)
    For i = 2 To UBound(a)
        If a(i, 1) <> "" Then
            For j = 3 To UBound(a, 2)
            If a(i, j) = "F" Then
                say = say + 1
                b(say, 1) = a(i, 1)
                b(say, 2) = a(i, 2)
                b(say, 3) = a(1, j)
                b(say, 4) = a(i, j)
                End If
            Next j
        End If
    Next i
s2.Range("A4:D" & Rows.Count) = Empty
    If say > 0 Then
        s2.[A4].Resize(say).NumberFormat = "@"
        s2.[C4].Resize(say).NumberFormat = "dd.mm.yyyy"
        s2.[A4].Resize(say, 4) = b
        MsgBox "İşlem tamam.", vbInformation
    Else
        MsgBox "Aktarılacak veri bulunamadı.", vbCritical
    End If
End Sub
 
A

alirizapekbilir

Katılım
11 Şubat 2016
Mesajlar
199
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
15-02-2021
Teşekkürler hocam emeğinize sağlık. Eve gidince deneyeceğim. If a(i, j) = "F" Then buraya duruma göre ilave kod ekleme yapabilirmiyim. Şu an gerekli değil ama eklenmesi gerekebilir.
 
A

alirizapekbilir

Katılım
11 Şubat 2016
Mesajlar
199
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
15-02-2021
Teşekkürler çok güzel çalıştı elinize sağlık.
 
burhancavus61

burhancavus61

Altın Üye
Katılım
13 Mayıs 2005
Mesajlar
761
Excel Vers. ve Dili
2010 Türkçe
Altın Üyelik Bitiş Tarihi
03.11.2024
Ziynettin Hocam merhaba. Bana bir kodda yardımcı olmuştunuz bir düzenlemeye ihtiyacım oldu. Yardım etmeniz mümkünmü. Kod çalışıyor sadece ArşivP sayfasında son dolu hücreden başlamasını nasıl sağlarız. Her taşımada Puantajı ArşivP sayfasının son dolu hücresinden itibaren aktarmaya başlasın. Mükerrer olanları bi şekilde ben hallederim. Zahmet veriyorum size kusura bakmayın.

Kod: 
Sub calistir()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Puantaj")
Set s2 = Sheets("ArşivP")
son = s1.Cells(Rows.Count, "J").End(3).row
a = s1.Range("K5:AR" & son).Value
ReDim b(1 To Rows.Count, 1 To 4)
    For i = 2 To UBound(a)
        If a(i, 1) <> "" Then
            For j = 3 To UBound(a, 2)
            If a(i, j) = "X" Then
                           say = say + 1
                b(say, 1) = a(i, 1)
                b(say, 2) = a(i, 2)
                b(say, 3) = a(1, j)
                b(say, 4) = a(i, j)
                End If
            Next j
        End If
        
        If a(i, 1) <> "" Then
            For j = 3 To UBound(a, 2)
            If a(i, j) = "İ" Then
                           say = say + 1
                b(say, 1) = a(i, 1)
                b(say, 2) = a(i, 2)
                b(say, 3) = a(1, j)
                b(say, 4) = a(i, j)
                End If
            Next j
        End If

        If a(i, 1) <> "" Then
            For j = 3 To UBound(a, 2)
            If a(i, j) = "AT" Then
                           say = say + 1
                b(say, 1) = a(i, 1)
                b(say, 2) = a(i, 2)
                b(say, 3) = a(1, j)
                b(say, 4) = a(i, j)
                End If
            Next j
        End If

        If a(i, 1) <> "" Then
            For j = 3 To UBound(a, 2)
            If a(i, j) = "P" Then
                           say = say + 1
                b(say, 1) = a(i, 1)
                b(say, 2) = a(i, 2)
                b(say, 3) = a(1, j)
                b(say, 4) = a(i, j)
                End If
            Next j
        End If
        
        If a(i, 1) <> "" Then
            For j = 3 To UBound(a, 2)
            If a(i, j) = "R" Then
                           say = say + 1
                b(say, 1) = a(i, 1)
                b(say, 2) = a(i, 2)
                b(say, 3) = a(1, j)
                b(say, 4) = a(i, j)
                End If
            Next j
        End If

        If a(i, 1) <> "" Then
            For j = 3 To UBound(a, 2)
            If a(i, j) = "F" Then
                           say = say + 1
                b(say, 1) = a(i, 1)
                b(say, 2) = a(i, 2)
                b(say, 3) = a(1, j)
                b(say, 4) = a(i, j)
                End If
            Next j
        End If
        
        If a(i, 1) <> "" Then
            For j = 3 To UBound(a, 2)
            If a(i, j) = "Mİ" Then
                           say = say + 1
                b(say, 1) = a(i, 1)
                b(say, 2) = a(i, 2)
                b(say, 3) = a(1, j)
                b(say, 4) = a(i, j)
                End If
            Next j
        End If

        If a(i, 1) <> "" Then
            For j = 3 To UBound(a, 2)
            If a(i, j) = "Üİ" Then
                           say = say + 1
                b(say, 1) = a(i, 1)
                b(say, 2) = a(i, 2)
                b(say, 3) = a(1, j)
                b(say, 4) = a(i, j)
                End If
            Next j
        End If

        If a(i, 1) <> "" Then
            For j = 3 To UBound(a, 2)
            If a(i, j) = "B" Then
                           say = say + 1
                b(say, 1) = a(i, 1)
                b(say, 2) = a(i, 2)
                b(say, 3) = a(1, j)
                b(say, 4) = a(i, j)
                End If
            Next j
        End If

        If a(i, 1) <> "" Then
            For j = 3 To UBound(a, 2)
            If a(i, j) = "FA" Then
                           say = say + 1
                b(say, 1) = a(i, 1)
                b(say, 2) = a(i, 2)
                b(say, 3) = a(1, j)
                b(say, 4) = a(i, j)
                End If
            Next j
        End If

        If a(i, 1) <> "" Then
            For j = 3 To UBound(a, 2)
            If a(i, j) = "XX" Then
                           say = say + 1
                b(say, 1) = a(i, 1)
                b(say, 2) = a(i, 2)
                b(say, 3) = a(1, j)
                b(say, 4) = a(i, j)
                End If
            Next j
        End If

        If a(i, 1) <> "" Then
            For j = 3 To UBound(a, 2)
            If a(i, j) = "/" Then
                           say = say + 1
                b(say, 1) = a(i, 1)
                b(say, 2) = a(i, 2)
                b(say, 3) = a(1, j)
                b(say, 4) = a(i, j)
                End If
            Next j
        End If
    
    Next i
s2.Range("B4:E" & Rows.Count) = Empty
    If say > 0 Then
        s2.[B3].Resize(say).NumberFormat = "@"
        s2.[D3].Resize(say).NumberFormat = "dd.mm.yyyy"
        s2.[B3].Resize(say, 4) = b
        MsgBox "İşlem tamam.", vbInformation
    Else
        MsgBox "Aktarılacak veri bulunamadı.", vbCritical
    End If
End Sub
 
Z

Ziynettin

Destek Ekibi
Destek Ekibi
Katılım
18 Nisan 2008
Mesajlar
1,105
Excel Vers. ve Dili
office2010
Kodu çalıştığında ArşivP sayfası dolu satırdan sonra listeler. Doğru mu? anladım.



Kod: 
Sub test()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Puantaj")
Set s2 = Sheets("ArşivP")
son = s1.Cells(Rows.Count, "J").End(3).Row
aranan = Array("X", "İ", "AT", "P", "R", "F", "Mİ", "Üİ", "B", "FA", "XX", "/")
a = s1.Range("K5:AQ" & son).Value
ReDim b(1 To Rows.Count, 1 To 4)
    For i = 2 To UBound(a)
        If a(i, 1) <> "" Then
            For j = 3 To UBound(a, 2)
                For k = 0 To UBound(aranan)
                    If a(i, j) = aranan(k) Then
                        say = say + 1
                        b(say, 1) = a(i, 1)
                        b(say, 2) = a(i, 2)
                        b(say, 3) = a(1, j)
                        b(say, 4) = a(i, j)
                    End If
                Next k
            Next j
        End If
    Next i
    If say > 0 Then
        satir = s2.Cells(Rows.Count, 2).End(3).Row
        If satir < 4 Then satir = 4
        s2.Cells(satir, 2).Resize(say, 4).NumberFormat = "@"
        s2.Cells(satir, 2).Resize(say, 4) = b
        MsgBox "İşlem tamam.", vbInformation
    Else
        MsgBox "Aktarılacak veri bulunamadı.", vbCritical
    End If
End Sub
 
burhancavus61

burhancavus61

Altın Üye
Katılım
13 Mayıs 2005
Mesajlar
761
Excel Vers. ve Dili
2010 Türkçe
Altın Üyelik Bitiş Tarihi
03.11.2024
Evet hocam dopru kontrol ediyorum
 
burhancavus61

burhancavus61

Altın Üye
Katılım
13 Mayıs 2005
Mesajlar
761
Excel Vers. ve Dili
2010 Türkçe
Altın Üyelik Bitiş Tarihi
03.11.2024
Ustad tarih alanının tarih formatında olursa mükemmel olacak. Gerisi mükemmel çalışıyor
 
burhancavus61

burhancavus61

Altın Üye
Katılım
13 Mayıs 2005
Mesajlar
761
Excel Vers. ve Dili
2010 Türkçe
Altın Üyelik Bitiş Tarihi
03.11.2024
Tamam hocam sorunu çözdüm emeğine sağlık
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst