Macro ile iki sayfa arasındaki seri no ları karşılaştırıp koşula göre oluşturma

[levoni]

Merhaba Değerli Arkadaşlar,
Çok uzun zaman alan bir dizi işlemleri macro yardımıyla kısa sürede yapıp zamandan kazanıp hatasız şekilde yapmak istiyorum.Bu konuda vaktiniz olduğunda yardımcı olabilirseniz çok sevinirim.
Yapmak istediklerimi daha anlaşılır olması açısından madde madde yazmak istiyorum.
1-"POS Seri Numara Listesi" listesindeki "D" sütununda ki Seri No değerini "Pos Listesi Değişim" sayfasında bulunan "C" sütunundaki Seri No lar ile karşılaştırılıp

2-"Pos Listesi Değişim" sayfasında olup da "POS Seri Numara Listesi" olmayan satırlar "POS Seri Numara Listesi" sayfasına ekliyoruz.
3-.....
4-.....
Çok uzun olmasın diye bu yazının devamı örnek dosyanın içersinde detaylı olarak yazdım. (Açıklamalar 2560. satırdan başlıyor)

Örnek dosyayı ve Olması gereken dosyayı ekte bilgilerinize sunuyorum.

Yardımcı olabilirseniz çok sevinirim.Herhalükarda şimdiden tşk ler.

İyi çalışmalar

 

[levoni]

Değerli hocalarım merhaba,
bu konuda yapılabilecek bir şey var mıdır acaba.Rica etsem değerli vaktiniz alıp bakma imkanınız olabilir mi ?Yarcımcı olabilirseniz çok memnun olurum.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu denermisiniz.

Sub SERİ_NO_KARŞILAŞTIR()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim X As Long, WF As WorksheetFunction, BUL As Range, Satır As Long
    
    Application.ScreenUpdating = False
    Set S1 = Sheets("POS Seri Numara Listesi")
    Set S2 = Sheets("Pos Listesi Değişim")
    Set S3 = Sheets("Fark")
    Set WF = WorksheetFunction
    Satır = 2
    
    For X = 2 To S2.Cells(Rows.Count, 1).End(3).Row
        If WF.CountIf(S1.Range("D:D"), S2.Cells(X, 3)) = 0 Then
            Set BUL = S1.Range("C2:C" & Rows.Count).Find(1, , , xlWhole)
            If Not BUL Is Nothing Then
                BUL.EntireRow.Insert
                S1.Cells(BUL.Row - 1, 2) = S2.Cells(X, 5)
                S1.Cells(BUL.Row - 1, 4) = S2.Cells(X, 3)
                S1.Cells(BUL.Row - 1, 6) = "S. Stokta"
                Select Case UCase(Replace(Replace(S2.Cells(X, 7), "i", "İ"), "ı", "I"))
                    Case Is = "K", "S", "A"
                        S1.Cells(BUL.Row - 1, 7) = "Sağlam"
                    Case Is = "SERVİS FİRMASINDA"
                        S1.Cells(BUL.Row - 1, 7) = "Servis Firmasında"
                    Case Is = "KARGO"
                        S1.Cells(BUL.Row - 1, 7) = "Kargo"
                End Select
            End If
            Set BUL = Nothing
        End If
    Next
                
    For X = S1.Cells(Rows.Count, 1).End(3).Row To 2 Step -1
        If WF.CountIf(S2.Range("C:C"), S1.Cells(X, 4)) = 0 Then
            S1.Rows(X).Copy S3.Cells(Satır, 1)
            S1.Rows(X).EntireRow.Delete
            Satır = Satır + 1
        End If
    Next
                
    If S1.Range("B2") <> "" Then
        S1.Range("A2:A" & Rows.Count).ClearContents
        S1.Range("A2") = 1
        S1.Range("A2:A" & S1.Cells(Rows.Count, 2).End(3).Row).DataSeries _
        Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set WF = Nothing
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[levoni]

Sayın Korhan Bey,

Gerçekten çok tşk ederim ellerinize aklınıza sağlık.Tık diye sorunsuz çalıştı.Gecenin bu saatinde zahmet etmişsiniz, sizi yorduk kusura bakmayın.