karşılaştırma ve eksik olanları ekleme yardımı

[aykiri]

Merhaba arkadaşlar
örnek tabloda sayfa1 ve sayfa2 mevcuttur

sayfa1 eski liste
sayfa2 ise güncel listedir.

sayfa2 deki veriler ile sayfa1 karşılaştırılacak ve eksik olanlar sayfa1 insert edilerek eklenecek

yardımcı olursanız sevinirim

 

[askm]

Aşağıdaki şekilde deneyin. Yeni eklenenleri sarı renge boyuyor.

Sub ASKM()
Dim s1, s2 As Worksheet
Set s1 = Sheets("SAYFA1")
Set s2 = Sheets("SAYFA2")
Dim SonSat1, SonSat2 As Long
SonSat2 = s2.Range("A" & Rows.Count).End(xlUp).Row
Adet = 0
For i = 2 To SonSat2
    SonSat1 = s1.Range("A" & Rows.Count).End(xlUp).Row + 1
    Sayi = WorksheetFunction.CountIf(s1.Range("A2:A" & SonSat1 - 1), s2.Cells(i, "A"))
    If Sayi = 0 Then
         s2.Range("A" & i & ":D" & i).Copy s1.Range("A" & SonSat1)
         s1.Range("A" & SonSat1 & ":D" & SonSat1).Interior.Color = vbYellow
         s2.Range("A" & i & ":D" & i).Interior.Color = vbRed
         Adet = Adet + 1
    End If
Next
MsgBox Adet & " verinin kopyalama işlemi yapıldı...", vbInformation, "ASKM"
End Sub

 

[aykiri]

sn askm
örnek kodu denedim kopyalama derken insert olması gerekiyor
yani gerçek sırasına insert etmeli
bu şekilde çözülebilirmi ?

ilgniz için sağolun

 

[askm]

Kodun en sonuna sıralama eklemek işinizi görür mü?

 

[aykiri]

kendi sırasına insert etme olasılığı mümkünmü ?

 

[askm]

Aşağıdaki şekilde deneyin bir.

Sub ASKM()
Dim s1, s2 As Worksheet
Set s1 = Sheets("SAYFA1")
Set s2 = Sheets("SAYFA2")
Dim SonSat1, SonSat2 As Long
SonSat2 = s2.Range("A" & Rows.Count).End(xlUp).Row
s1.Cells.Interior.Color = xlNone
s2.Cells.Interior.Color = xlNone
Adet = 0
For i = 2 To SonSat2
    SonSat1 = s1.Range("A" & Rows.Count).End(xlUp).Row + 1
    Sayi = WorksheetFunction.CountIf(s1.Range("A2:A" & SonSat1 - 1), s2.Cells(i, "A"))
    If Sayi = 0 Then
         s2.Range("A" & i & ":D" & i).Copy s1.Range("A" & SonSat1)
         s1.Range("A" & SonSat1 & ":D" & SonSat1).Interior.Color = vbYellow
         s2.Range("A" & i & ":D" & i).Interior.Color = vbRed
         Adet = Adet + 1
    End If
Next
Call ASKM_Sirala

MsgBox Adet & " verinin kopyalama işlemi yapıldı...", vbInformation, "ASKM"
End Sub
Sub ASKM_Sirala()
    ActiveWorkbook.Worksheets("SAYFA1").ListObjects("Table34").Sort.SortFields.Add _
        Key:=Range("Table34[DATA0]"), SortOn:=xlSortOnValues, Order:=xlAscending _
        , DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("SAYFA1").ListObjects("Table34").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

 

[aykiri]

kopyalama yaparken aynı numaraya sahip olanları işleme almıyor

aynı numaralar olsada sırayı hiç bozmadan eşleştirme yapmasını istiyorum

kısaca istediğim şu .

sayfa 2 de ne varsa aynısını sayfa1 e kopyalasın fakat kopyalasın derken aralara insert etsin manasında söylüyorum çünkü sağa doğru işlenmiş veriler olacak kopyala yapıştır işi olmaz.

bu konuda yardıma ihtiyacım var
makro olması şart değil formulde olabilir

 

[aykiri]

bu konuda yardım edebilecek uzman arkadaşlar varsa memnun olurum
internette bulduğum örnekler işe yaramadı

 

[Asri]

Alternatif;

Aşağıdaki şekilde deneyiniz.

Sub olmayani_ekle()
   Application.ScreenUpdating = False
   Set Sh1 = Sheets("Sayfa1")
   Set Sh2 = Sheets("Sayfa2")

   sh2sonsatir = Sh2.Cells(Rows.Count, "A").End(3).Row
   
   For i = 2 To sh2sonsatir
     sh2kod = Sh2.Cells(i, 1).Value
     sh1kod = Sh1.Cells(i, 1).Value
     If sh1kod <> sh2kod Then
        Sh2.Rows(i & ":" & i).Copy
        Sh1.Rows(i & ":" & i).Insert Shift:=xlDown
     End If
   Next i
   Application.ScreenUpdating = True
End Sub

 

[aykiri]

sn asri çok iyi çalışıytor teşekkürler