Çok sayfada Mükerrer kayıt

[honestguy25]

selamlar. veri sayfasından çok sayfaya veri aktarıyorum fakat güncellediğimde sayfalarda mükerrer kayıt oluyor. açıkcası siteden aldıım kodları uyarlayarak yaptım dosyaı o yuzden biraz garip oldu fakat bu mükerrer kayıt olayına çozum bulamadım sitede hep aynı sayfalar ıcındeki mukerrerliğe cozum uretılmış.

teşekkur ediyorum.. bu son problemim gibi gorunuyor.. yardımcı olabilirseniz çok sevinirim.

 

[honestguy25]

dosyayı ekleyememişim şimdi eklıyorum

 

[honestguy25]

bu konuda fikri olan yok mu acaba...?

 

[honestguy25]

Sub DAGIT()
Dim i, j, xr, sira As Long, Sayfa As String, S1 As Worksheet
Set S1 = Sheets("Bibliography")
Application.ScreenUpdating = False
For i = 3 To S1.[c65536].End(3).Row
Sayfa = S1.Cells(i, "C")
If Not Sayfakontrol(Sayfa) Then

Sheets("DRAFT").Select
Sheets("DRAFT").Copy After:=Worksheets(Worksheets.Count)
Sheets("DRAFT (2)").Select
Sheets("DRAFT (2)").Name = Sayfa
End If

sira = Sheets(Sayfa).[A65536].End(3).Row + 1

xr = Sheets(Sayfa).Range("p" & Rows.Count).End(xlUp).Row
If Application.WorksheetFunction.CountIf(Sheets(Sayfa).Range("p2" & xr), S1.Range("p" & i)) > 0 Then
GoTo atla
Else
Sheets(Sayfa).Range("A" & sira & ":l" & sira).Value = S1.Range("A" & i & ":l" & i).Value

Sheets(Sayfa).Range("A:l").EntireColumn.AutoFit
End If
atla:
Next i
Set S1 = Nothing
Application.ScreenUpdating = True
End Sub
Function Sayfakontrol(SAYFAADI As String) As Boolean
On Error Resume Next
Sayfakontrol = CBool(Len(Worksheets(SAYFAADI).Name) > 0)
End Function


bu makro ıle dağıttıımda sayfalarda guncelemele durumunda mukerrer kayıt oluşuyor ne yapmam lazım?? fikir olarak yardımcı olabılecek hocalarıma saygılarımı sunuyorum

 

[Husgvarna]

bu makro ıle dağıttıımda sayfalarda guncelemele durumunda mukerrer kayıt oluşuyor ne yapmam lazım?? fikir olarak yardımcı olabılecek hocalarıma saygılarımı sunuyorum

Merhaba.
Şöyle deneyin.

 Sub DAGIT()
    Dim i, j, xr, sira As Long, Sayfa As String, S1 As Worksheet
    Set S1 = Sheets("Bibliography")
    Application.ScreenUpdating = False
    For i = 3 To S1.[c65536].End(3).Row
        Sayfa = S1.Cells(i, "C")
        If Not Sayfakontrol(Sayfa) Then

            Sheets("DRAFT").Select
            Sheets("DRAFT").Copy After:=Worksheets(Worksheets.Count)
            Sheets("DRAFT (2)").Select
            Sheets("DRAFT (2)").Name = Sayfa
        End If

        sira = Sheets(Sayfa).[A65536].End(3).Row + 1

     If Application.WorksheetFunction.CountIf(Sheets(Sayfa).Range("e2:e65000"), S1.Range("e" & i)) > 0 Then
            GoTo atla
        Else
            Sheets(Sayfa).Range("A" & sira & ":k" & sira).Value = S1.Range("A" & i & ":k" & i).Value

            Sheets(Sayfa).Range("A:k").EntireColumn.AutoFit
        End If
atla:
    Next i
    Set S1 = Nothing
    Application.ScreenUpdating = True
End Sub

 

[honestguy25]

çok teşekkur ederim. şimdilik oldu gibi. dosyam genişledikce başka sorunlarla karşılaşıyorum.. yardımınız ıçın teşekkurler.