Kod Yardımı

meyill · 1 Mart 2016

Merhaba Arkadaşlar. Hazırlamaya çalıştığım bir kod için sürekli uyarı alıyorum. Nerede yanlış yaptığımı anlatacak arkadaşlara minnettar olurum.
Yapmaya çalıştığım kodu anlatayım. Ekders Sayfasında hazırladığım verileri Çizelge sayfasına aktarıyorum. Find ile ad aramaktayım ad var ise güncellesin, ad yok ise yeni satırda yazsın.

Kod:

Sub kaydet()

Set s1 = Worksheets("Puantaj")
Set s2 = Worksheets("Çizelge")
Set s3 = Worksheets("Ekders Hazırla")
Set s4= Worksheets("Anasayfa")
Application.ScreenUpdating = False
Set ad = s4.Range("B:B").Find(s3.Cells(2, 3), LookIn:=xlValues)
a = ad.Row
ay = s4.Cells(4, "e")
Range("B6:C16").ClearContents
s2.Cells(1, 3) = s4.Cells(a, "e")
s2.Cells(3, 3) = s4.Cells(a, "d")
s2.Cells(4, 3) = s4.Cells(a, "g")
s2.Cells(2, 3) = s4.Cells(4, 3)
s2.Cells(2, 4) = s4.Cells(4, 4)
s2.Cells(1, "j") = s4.Cells(a, "f")
s2.Cells(2, "j") = s4.Cells(a, "h") & " / " & s4.Cells(a, "i")

s4.Select
For i = 6 To s3.[D65536].End(xlUp).Row
If Not s3.Cells(i, "d") = "" Then
s3.Cells(i, "e") = Application.WorksheetFunction.VLookup(ekders.Cells(i, "d"), s4.Range("M2:N23"), 2, False)
Else
s3.Cells(i, "e") = ""
End If
Next i
s3.Select
For i = 6 To 16
  For j = 6 To 42
  s2.Cells(4, j) = s3.Cells(3, j)
  s2.Cells(5, j) = s3.Cells(5, j)
  s2.Cells(5, 43) = s3.Cells(5, 43)
    If WorksheetFunction.CountA(Cells(i, j)) > 0 Then
    Cells(i, 2) = s4.Cells(a, 2)
    Cells(i, 3) = s4.Cells(a, 3)
    Cells(i, "aq") = Cells(3, 3) & "-" & Cells(4, 5) & "-" & ay & "-" & Cells(i, "e")
    Cells(i, "ar") = s4.Cells(a, "e")
    Cells(i, "as") = Cells(4, "e") & " - " & Cells(3, "e")
    End If
  Next j
Next i

s2.Cells(1, "aq") = 1
s2.Cells(2, "aq") = 2
s2.Cells(3, "aq") = 3
s2.Cells(4, "aq") = 4
s2.Cells(5, "aq") = "T.C.KimlikNo-Yıl-Ay-Kod"
s2.Cells(5, "ar") = "Kurumu"
s2.Cells(5, "as") = "Ödeme Ay - Yıl"



For i = 6 To s3.[AQ65536].End(xlUp).Row
        If WorksheetFunction.CountIf(s2.[AQ:AQ], s3.Cells(i, "aq")) = 0 Then
        satır = s2.Cells(1, "aq").End(xlDown).Row + 1
        'If WorksheetFunction.CountIf(s2.Range("aq6:aq65536"), s3.Cells(i, "aq")) = 1 Then
        Else
        satır = s2.[AQ:AQ].Find(what:=s3.Range("AQ" & i)).Row 'Cells(i, "aq")).Row
        End If
    For Z = 2 To 45
    s2.Cells(satır, Z) = s3.Cells(i, Z)
    Next Z
Next i
End Sub

meyill · 1 Mart 2016

Bu konuda fikri olan yok galiba. Aldığım hata mesajı resimdeki gibi. hata kodunu bilen vardır belki.

meyill · 3 Mart 2016

Günlerdir Yardım bekledim fakat nafile kendi sorunumu kendim tarzanca buldum. ilgilenen arkadaşlara teşekkürler..

Kod:

Sub kaydet()

Set puan = Worksheets("Puantaj")
Set s1 = Worksheets("Çizelge")
Set s2 = Worksheets("Ekders Hazırla")
Set s3 = Worksheets("Anasayfa")
Dim satır As Byte
Application.ScreenUpdating = False
Set ad = s3.Range("B:B").Find(s2.Cells(2, 3), LookIn:=xlValues)
a = ad.Row
ay = s3.Cells(4, "e")
Range("B6:C16").ClearContents
Cells(1, 3) = s3.Cells(a, "e")
Cells(3, 3) = s3.Cells(a, "d")
Cells(4, 3) = s3.Cells(a, "g")
s1.Cells(2, 3) = s3.Cells(4, 3)
s1.Cells(2, 4) = s3.Cells(4, 4)
Cells(1, "j") = s3.Cells(a, "f")
Cells(2, "j") = s3.Cells(a, "h") & " / " & s3.Cells(a, "i")
s3.Select
For i = 6 To s2.[D65536].End(xlUp).Row
If Not s2.Cells(i, "d") = "" Then
s2.Cells(i, "e") = Application.WorksheetFunction.VLookup(s2.Cells(i, "d"), s3.Range("M2:N23"), 2, False)
Else
s2.Cells(i, "e") = ""
End If
Next i
s2.Select
For i = 6 To 16
  For j = 6 To 42
  s1.Cells(4, j) = s2.Cells(3, j)
  s1.Cells(5, j) = s2.Cells(5, j)
  s1.Cells(5, 43) = s2.Cells(5, 43)
    If WorksheetFunction.CountA(Cells(i, j)) > 0 Then
    Cells(i, 2) = s3.Cells(a, 2)
    Cells(i, 3) = s3.Cells(a, 3)
    Cells(i, "aq") = Cells(3, 3) & "-" & Cells(4, 5) & "-" & ay & "-" & Cells(i, "e")
    Cells(i, "ar") = s3.Cells(a, "e")
    Cells(i, "as") = Cells(4, "e") & " - " & Cells(3, "e")
    End If
  Next j
Next i
s1.Cells(1, "aq") = 1
s1.Cells(2, "aq") = 2
s1.Cells(3, "aq") = 3
s1.Cells(4, "aq") = 4
s1.Cells(5, "aq") = "T.C.KimlikNo-Yıl-Ay-Kod"
s1.Cells(5, "ar") = "Kurumu"
s1.Cells(5, "as") = "Ödeme Ay - Yıl"
s1.Select
For k = 6 To [aq65536].End(3).Row
If WorksheetFunction.CountIf(s2.Range("AQ6:AQ19"), s1.Cells(k, "aq")) = 1 Then s1.Rows(k).ClearContents
Next k
For i = 6 To s2.[aq65536].End(xlUp).Row
    satır = s1.[AQ:AQ].End(xlDown).Row + 1
    For Z = 2 To 45
    s1.Cells(satır, Z) = s2.Cells(i, Z)
    Next Z
Next i
Sheets("Çizelge").Select
sonsatır = Cells(65536, "b").End(3).Row
s1.Range("B6:AS" & sonsatır).Sort Key1:=Range("B6"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
For ma = 6 To sonsatır
s1.Cells(ma, "a") = ma - 5
Next ma
Sheets("Ekders Hazırla").Select
Application.ScreenUpdating = True
MsgBox (Cells(2, "c") & "' in Ekders bilgileri Çizelgeye kaydedildi.")
End Sub

Kod Yardımı

meyill

meyill

meyill