Macroda düzenleme hk

[levoni]

Sayın Korhan Bey merhaba,
Öncelikle sizin adınıza yazdığım için, sizden ve site yönetiminden özür dilerim.Ekte gönderdiğim macroyu sizin yardımınız ile yaptğım için size yazdım.Eğer başka hocalarımızda yardımcı olabilirse tabiki çok sevinirim

Konu kısaca şu şekilde, hali hazırda macro "Pos Listesi Değişim" sayfasındaki değişikliğe göre "POS Seri Numara Listesi" nde sadece Seri no da ki değişikliğe göre gerekli değişikliği yapıyor herhangibir sorun yok.
Sorun şu; seri noları değişmeyen kayıtlarda "POS Seri Numara Listesi" sayfasındaki G sütünunu güncellemiyor.
Örneğin Seri no :123 olsun
"Pos Listesi Değişim" sayfasında Durumu:Arızalı ancak
"POS Seri Numara Listesi" sayfasında Durumu:Sağlam olarak kalıyor.
Olması gereken ise Arızalı olması gerekiyor.
Örnek dosyayı ekte gönderiyorum

Mümkünse yardımcı olabilirseniz çok sevinirim.
Tşk ler

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu deneyiniz.

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"
                    Case Is = "ARIZALI"
                        S1.Cells(BUL.Row - 1, 7) = "Arızalı"
                End Select
            End If
            Set BUL = Nothing
        Else
            Set BUL = S1.Range("D2:D" & Rows.Count).Find(S2.Cells(X, 3), , , xlWhole)
            If Not BUL Is Nothing Then
                Select Case UCase(Replace(Replace(S2.Cells(X, 7), "i", "İ"), "ı", "I"))
                    Case Is = "K", "S", "A"
                        S1.Cells(BUL.Row, 7) = "Sağlam"
                    Case Is = "SERVİS FİRMASINDA"
                        S1.Cells(BUL.Row, 7) = "Servis Firmasında"
                    Case Is = "KARGO"
                        S1.Cells(BUL.Row, 7) = "Kargo"
                    Case Is = "ARIZALI"
                        S1.Cells(BUL.Row, 7) = "Arızalı"
                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 günaydın,
Elinize sağlık olmuş ancak küçük bir sorun var şöyleki; satırlarda sanki 1 satır kayma var.
Örneğin Seri no:211-798-440 bu olan örnekte "Arızalı" iken diğer tarafa geçerken bir altındaki kaydı dikkate alarak "Sağlam" olmuş.
Aynı örnek Durum kısmı "Kargo" yazan seri noda da görebilirsiniz.
Size zahmet musait olduğunuzda bakabilirseniz memnun olurum.

Tşk ler iyi çalışmalar

 

[Korhan Ayhan]

Merhaba,

Üstteki mesajımdaki kodu güncelledim. Denermisiniz.

 

[levoni]

Korhan Bey,
Tamamdır olmuş, çok tşk.
Bütün içtenliğimle söylüyorum Allah herşeyi gönlünüze göre versin