• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Puantaj yatay verileri dikey alma

A

alirizapekbilir

Katılım
11 Şubat 2016
Mesajlar
199
Excel Vers. ve Dili
2013
Ö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

Ü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.
 
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
 
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.
 
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
 
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
 
Ustad tarih alanının tarih formatında olursa mükemmel olacak. Gerisi mükemmel çalışıyor
 
Tamam hocam sorunu çözdüm emeğine sağlık
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst