Veri ara bul kaydet şeklinde bir veri aktarma gerekli

[kelkitli]

Değerli Dostlar Merhabalar,
Ekteki dosyada anlatmaya çalıştığım veri aktarmayla ilgili yardımlarınızı rica ediyorum. Sorduğum soru biraz külfetli oldu ama yapabilsem sizlere sıkıntı vermezdim. Aylık listeden Puantaja veri aktarmaya çalışıyorum. İlgilenen arkadaşlara şimdiden teşekkür ederim.

 

[veyselemre]

Sub Puantaj()
    Set sa = Sheets("AYLIKLİSTE")
    Set sp = Sheets("PUANTAJ")
    Set wf = WorksheetFunction
    On Error Resume Next

    bul = wf.Match(sa.[B1], sa.[a4:a34], 0)
    If Err <> 0 Then
        MsgBox "[AYLIKL&#304;STE] Sayfas&#305;nda Tarih Bulunamad&#305;. &#304;&#351;lem &#304;ptal Edildi." & vbCr & sa.[B1]
        Exit Sub
    End If

    bul2 = wf.Match(sa.[B1], sp.[C1:aU1], 0)
    If Err <> 0 Then
        MsgBox "[PUANTAJ] Sayfas&#305;nda Tarih Bulunamad&#305;. &#304;&#351;lem &#304;ptal Edildi." & vbCr & sa.[B1]
        Exit Sub
    End If

    For X = 3 To 20
        al = sa.Cells(bul + 3, X)
        If al > 0 Then
            alrenk = sa.Cells(bul + 3, X).Font.ColorIndex
            yaz = Array("", "", "", 1, 3, 2)(alrenk)
            d = sp.[A2:A68].Value
            bul3 = wf.Match(Trim(al), sp.[A2:A68], 0)
            If Err <> 0 Then
                MsgBox "[PUANTAJ] Sayfas&#305;nda Yaka Numaras&#305; Bulunamad&#305;. &#304;&#351;lem &#304;ptal Edildi." & vbCr & al
                Exit Sub
            End If

            sp.Cells(bul3 + 1, bul2 + 1).Value = yaz

        End If
    Next X
    Set sa = Nothing
    Set sp = Nothing
    Set wf = Nothing
End Sub

 

[kelkitli]

Sn. Veyselemre Merhaba, Cevabınız için çok çok çok teşekkür ederim. Benim nezdimde çok insanlığa geçti. Yalnız şöyle birşey var. Puantaj sayfasında tarih ararken 01.01.2007 yazınca isim hanesine veri kaydediyor. Diğer tarihleride bir gün önceye kaydediyor. Bi bakabilirseniz sevinirim.

 

[veyselemre]

Aşağıdaki düzeltmeyi yapın.
sp.Cells(bul3 + 1, bul2 + 2).Value = yaz

 

[kelkitli]

Sn. Veyselemre sağol varol hep bu forumda ol. Çok teşekkür ederim.

 

[kelkitli]

Sn.Veyselemre yazmış olduğunuz kodun içerisine 3 To 20 döngüsüne ilave olarak 22 to 39 bölümünü de eklemeye çalıştım bir de ayın 1 inden 31 ine kadar döngü yapmak istiyorum ancak başaramadım. Aynı kodları 2. kez 2. makro olarak kopyaladım. Tek makro içerisine Yazma imkanımız olurmu?

 

[veyselemre]

Sub Puantaj()
    Set sa = Sheets("AYLIKLİSTE")
    Set sp = Sheets("PUANTAJ")
    Set wf = WorksheetFunction
    On Error Resume Next
    '**********bu kısım ayın 1 inden ayın son gününe kadar döngü için****************
    ay = Month(sa.[b1])
    yil = Year(sa.[b1])
    aysongun = Day(DateSerial(yil, ay + 1, 0))

    For gun = 1 To aysongun
        sa.[b1] = DateSerial(yil, ay, gun)
        '*********************************************************************************
        bul = wf.Match(sa.[b1], sa.[a4:a34], 0)
        If Err <> 0 Then
            MsgBox "[AYLIKL&#304;STE] Sayfas&#305;nda Tarih Bulunamad&#305;. &#304;&#351;lem &#304;ptal Edildi." & vbCr & sa.[b1]
            Exit Sub
        End If

        bul2 = wf.Match(sa.[b1], sp.[C1:aU1], 0)
        If Err <> 0 Then
            MsgBox "[PUANTAJ] Sayfas&#305;nda Tarih Bulunamad&#305;. &#304;&#351;lem &#304;ptal Edildi." & vbCr & sa.[b1]
            Exit Sub
        End If

        For x = 22 To 50
            If x = 21 Or x = 40 Then GoTo skip
            al = sa.Cells(bul + 3, x)
            If al > 0 Then
                alrenk = sa.Cells(bul + 3, x).Font.ColorIndex
                yaz = Array("", "", "", 1, 3, 2)(alrenk)
                d = sp.[A2:A68].Value
                bul3 = wf.Match(Trim(al), sp.[A2:A68], 0)
                If Err <> 0 Then
                    MsgBox "[PUANTAJ] Sayfas&#305;nda Yaka Numaras&#305; Bulunamad&#305;. &#304;&#351;lem &#304;ptal Edildi." & vbCr & al
                    Exit Sub
                End If

                sp.Cells(bul3 + 2, bul2 + 2).Value = yaz
            End If
skip:
        Next x
    Next gun    ' bu k&#305;s&#305;mda ay&#305;n g&#252;nleri i&#231;in eklendi.
    Set sa = Nothing
    Set sp = Nothing
    Set wf = Nothing
    MsgBox "&#304;&#351;lem Tamamland&#305;.........."
End Sub

 

[kelkitli]

Sn.veyselemre,
teşekkürlerimi iletirim. Allah şu anki bilginizin katlarını versin.

 

[kelkitli]

Değerli Dostlar,
Forumdaki arkadaşların yardımıyla hazırladığım "Aylık Liste" den "Puantaj girişi" çalışmamı ekte sunuyorum. İsteyen arkadaşlar alabilir düzeltebilir tekrar bizlere sunabilir kendileri kullanabilir. Yardımcı olan arkadaşlara teşekkür ederim.