MsgBox ile farklı olanları görmek

nadirornek · 31 Mayıs 2020

MsgBox bildirim dosyamın Veri sayfasının I sutununda olupta D sutununda olmayan veriyi MsgBox yardımı ile görmek istiyordum.Bir kod yardımı ile görebilirmiyim.

nadirornek · 31 Mayıs 2020

MsgBox bildirim dosyamın Veri sayfasının I sutununda olupta D sutununda olmayan veriyi MsgBox yardımı ile görmek istiyordum.Bir kod yardımı ile görebilirmiyim.

muygun · 31 Mayıs 2020

Merhaba;
Eki deneyin.
İyi çalışmalar.

ÖmerFaruk · 31 Mayıs 2020

C++:

Sub MsgBoxGöster()
Dim Bak As Range
Set Bak = Range("D3:D" & Range("D3").End(xlDown).Row)
Mesaj = "Aşağaıdakiler D sütununda Yok"
Son = Cells(3, 9).End(xlDown).Row
For i = 3 To 2384 'I sütunuda içi boş ya da okunamayan karakterleriniz var'
    If WorksheetFunction.CountIf(Bak, Cells(i, 9)) = 0 Then
    Mesaj = Mesaj & Chr(13) & Cells(i, 9)
    Yok = True
    End If
Next i

If Yok Then
    MsgBox Mesaj
Else
    MsgBox "D sütununun hepsi I sütununda var"
End If
End Sub

nadirornek · 31 Mayıs 2020

Kodların ikiside güzel, yanlız olmayan aynı veriyi 850 birden fazla yazıyor bir tanesini yazarsa daha güzel olur teşekkürler.

nadirornek · 31 Mayıs 2020

Sub işlem()
Application.ScreenUpdating = False
On Error Resume Next
Range("ı3:ı65536").Interior.ColorIndex = xlNone
sonn = Range("d65536").End(xlUp).Row
For i = 3 To Range("ı65536").End(xlUp).Row
If WorksheetFunction.CountIf(Range("d3:d" & sonn), Cells(i, "ı")) = 0 And Cells(i, "ı") <> "" Then
bull = bull & " " & Cells(i, "ı")
Cells(i, "ı").Interior.ColorIndex = 46
End If
Next i
Application.ScreenUpdating = True
MsgBox bull, vbInformation

Range("I2").Select
Selection.AutoFilter
ActiveSheet.Range("$I$2:$I$2383").AutoFilter Field:=1, Criteria1:=RGB(255, _
102, 0), Operator:=xlFilterCellColor
End Sub

İşlem koduna süz kodunu ekleyerek daha güzel oldu. Bul kodunda aynı olmayanı birden fazla gösteriyor, bir tanesini gösterirse dahada güzel olaçak , MsgBox gösterisi 840 850 olması gibi renklendirmede ayrıca güzel olmuş.

Korhan Ayhan · 1 Haziran 2020

Deneyiniz.

Hız kaybı olmaması için renk olayını kullanmadım.

C++:

Option Explicit

Sub Farkli_Olanlari_Goster()
    Dim Son_D As Long, Son_I As Long, Veri As Variant, X As Long
    Dim Kriter As Variant, Key As Variant, Say As Long
    
    Application.ScreenUpdating = False
    
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
    
    Son_D = Range("D:D").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    Son_I = Range("I:I").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row

    Range("AA1") = 1
    Range("AA1").Copy
    Range("I3:I" & Son_I).PasteSpecial Paste:=xlPasteValues, Operation:=xlMultiply
    Range("D3:D" & Son_D).PasteSpecial Paste:=xlPasteValues, Operation:=xlMultiply
    Range("AA1").ClearContents
    Range("I2").Select
    
    Veri = Range("I3:I" & Son_I).Value

    With CreateObject("Scripting.Dictionary")
        For X = LBound(Veri) To UBound(Veri)
            If Not .Exists(Veri(X, 1)) Then
                .Add Veri(X, 1), Nothing
            End If
        Next

        Veri = Range("D3:D" & Son_D).Value
        
        For X = LBound(Veri) To UBound(Veri)
            If .Exists(Veri(X, 1)) Then
                .Remove Veri(X, 1)
            End If
        Next
        
        ReDim Kriter(1 To 1)
        
        For Each Key In .Keys
            Say = Say + 1
            ReDim Preserve Kriter(1 To Say)
            Kriter(Say) = CStr(Key)
        Next
        
        If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
        ActiveSheet.Range("I2:I" & Rows.Count).AutoFilter Field:=1, Criteria1:=Kriter, Operator:=xlFilterValues
        
        Application.ScreenUpdating = True
        
        MsgBox "I sütununda olup D sütununda olmayan değerler ;" & Chr(10) & Chr(10) & Join(.Keys, Chr(10))
    End With
End Sub

nadirornek · 13 Haziran 2020

Emeğinize sağlık Korhan Bey, güzel bir kod

nadirornek · 22 Eylül 2020

Ekli dosyamdaki kodlara biraz daha güzelleştirebilirmiyiz.
Farkli_Olanlari_Goster macroma tıkladığımda Veri sayfamın I sutununda bulduğu verileri kopyalayıp Sayfa1'in E2 hücresinden ihtibaren en son dolu hücrenin altına alt alta yapıştıracak ve H sutununda satır karşılığına İlave yazaçak.
Aynı şekilde
Farkli_Olanlari_Goster1 macroma tıkladığımda Veri sayfamın D sutununda bulduğu verileri kopyalayıp Sayfa1'in E2 hücresinden ihtibaren en son dolu hücrenin altına alt alta yapıştıracak ve H sutununda satır karşılığına Çıkan yazaçak.

Korhan Ayhan · 22 Eylül 2020

"I" sütununa göre kontrol edilince 4 satır veri listeleniyor. Bu 4 satır mı diğer sayfaya aktarılsın? Yoksa benzersiz olarak 2 satır mı aktarılsın?

nadirornek · 22 Eylül 2020

I sütununa göre benzersizlerin tamamı

Korhan Ayhan · 22 Eylül 2020

Deneyiniz.

C++:

Option Explicit

Sub Farkli_Olanlari_Goster_I_Sutunu()
    Dim Son_D As Long, Son_I As Long, Veri As Variant, X As Long
    Dim Kriter As Variant, Key As Variant, Say As Long
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Veri")
    Set S2 = Sheets("Sayfa1")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    With S1
        On Error Resume Next
        .ShowAllData
        On Error GoTo 0
    
        Son_D = .Range("D:D").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Son_I = .Range("I:I").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
        .Range("AA1") = 1
        .Range("AA1").Copy
        .Range("I3:I" & Son_I).PasteSpecial Paste:=xlPasteValues, Operation:=xlMultiply
        .Range("D3:D" & Son_D).PasteSpecial Paste:=xlPasteValues, Operation:=xlMultiply
        .Range("AA1").ClearContents
        .Range("I2").Select
    
        Veri = .Range("I3:I" & Son_I).Value
    
        For X = LBound(Veri) To UBound(Veri)
            If Not Dizi.Exists(Veri(X, 1)) Then
                Dizi.Add Veri(X, 1), Nothing
            End If
        Next

        Veri = .Range("D3:D" & Son_D).Value
        
        For X = LBound(Veri) To UBound(Veri)
            If Dizi.Exists(Veri(X, 1)) Then
                Dizi.Remove Veri(X, 1)
            End If
        Next
        
        ReDim Kriter(1 To Dizi.Count, 1 To 1)
        
        For Each Key In Dizi.Keys
            Say = Say + 1
            Kriter(Say, 1) = CStr(Key)
        Next
        
        If .AutoFilterMode = True Then .AutoFilterMode = False
        .Range("I2:I" & .Rows.Count).AutoFilter Field:=1, Criteria1:=Application.Transpose(Kriter), Operator:=xlFilterValues
    
        With S2.Cells(S2.Rows.Count, 5).End(3)(2, 1)
            .Resize(UBound(Kriter), 1) = Kriter
            .Offset(, 3).Resize(UBound(Kriter), 1) = "İlave"
        End With
        
        Application.ScreenUpdating = True
    
        MsgBox "I sütununda olup D sütununda olmayan değerler ;" & Chr(10) & Chr(10) & Join(Dizi.Keys, Chr(10))
    End With
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
End Sub

Sub Farkli_Olanlari_Goster_D_Sutunu()
    Dim Son_D As Long, Son_I As Long, Veri As Variant, X As Long
    Dim Kriter As Variant, Key As Variant, Say As Long
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Veri")
    Set S2 = Sheets("Sayfa1")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    With S1
        On Error Resume Next
        .ShowAllData
        On Error GoTo 0
    
        Son_D = .Range("D:D").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Son_I = .Range("I:I").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
        .Range("AA1") = 1
        .Range("AA1").Copy
        .Range("I3:I" & Son_I).PasteSpecial Paste:=xlPasteValues, Operation:=xlMultiply
        .Range("D3:D" & Son_D).PasteSpecial Paste:=xlPasteValues, Operation:=xlMultiply
        .Range("AA1").ClearContents
        .Range("I2").Select
    
        Veri = .Range("D3:D" & Son_D).Value
    
        For X = LBound(Veri) To UBound(Veri)
            If Not Dizi.Exists(Veri(X, 1)) Then
                Dizi.Add Veri(X, 1), Nothing
            End If
        Next

        Veri = .Range("I3:I" & Son_I).Value
        
        For X = LBound(Veri) To UBound(Veri)
            If Dizi.Exists(Veri(X, 1)) Then
                Dizi.Remove Veri(X, 1)
            End If
        Next
        
        ReDim Kriter(1 To Dizi.Count, 1 To 1)
        
        For Each Key In Dizi.Keys
            Say = Say + 1
            Kriter(Say, 1) = CStr(Key)
        Next
        
        If .AutoFilterMode = True Then .AutoFilterMode = False
        .Range("D2:D" & .Rows.Count).AutoFilter Field:=1, Criteria1:=Application.Transpose(Kriter), Operator:=xlFilterValues
    
        With S2.Cells(S2.Rows.Count, 5).End(3)(2, 1)
            .Resize(UBound(Kriter), 1) = Kriter
            .Offset(, 3).Resize(UBound(Kriter), 1) = "Çıkan"
        End With
        
        Application.ScreenUpdating = True
    
        MsgBox "D sütununda olup I sütununda olmayan değerler ;" & Chr(10) & Chr(10) & Join(Dizi.Keys, Chr(10))
    End With
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
End Sub

nadirornek · 23 Eylül 2020

Kod güzel çalışıyor emeğinize sağlık.Yanlız aşağıdaki hatayı veriyor.
object variable or With block variable not set
Nesne değişkeni veya bloğu değişkeni ayarlanmamış

nadirornek · 23 Eylül 2020

MsgBox "I sütununda olup D sütununda olmayan değerler ;" & Chr(10) & Chr(10) & Join(Dizi.Keys, Chr(10))
MsgBox "D sütununda olup I sütununda olmayan değerler ;" & Chr(10) & Chr(10) & Join(Dizi.Keys, Chr(10))

Kodların bu satırları hata veriyor.

Korhan Ayhan · 23 Eylül 2020

Revize ettim. Tekrar deneyiniz.

nadirornek · 23 Eylül 2020

Teşekkürler hata yok

nadirornek · 24 Eylül 2020

Korhan Bey,
Veri sayfasında D ve I sutun verilerini Shift = ile başka dosya sayfasından aldığımda, kodları çalıştırdığım zaman D ve I sutun verileri siliniyor #DEĞER! yazdırıyor.Bende D ve I sutunlarını kopyalayıp değer yapıştır yapıyorum.kodlar üzerinde bu sorunu giderebilirmiyiz.Sutunlar formüllü isede kodlar çalışsın teşekkürler.

Korhan Ayhan · 24 Eylül 2020

Deneyiniz.

C++:

Option Explicit

Sub Farkli_Olanlari_Goster_I_Sutunu()
    Dim Son_D As Long, Son_I As Long, Veri As Variant, X As Long
    Dim Kriter As Variant, Key As Variant, Say As Long
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Veri")
    Set S2 = Sheets("Sayfa1")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    With S1
        On Error Resume Next
        .ShowAllData
        On Error GoTo 0
    
        Son_D = .Range("D:D").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Son_I = .Range("I:I").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
        Veri = .Range("I3:I" & Son_I).Value
    
        For X = LBound(Veri) To UBound(Veri)
            If Not Dizi.Exists(Veri(X, 1)) Then
                Dizi.Add Veri(X, 1), Nothing
            End If
        Next

        Veri = .Range("D3:D" & Son_D).Value
        
        For X = LBound(Veri) To UBound(Veri)
            If Dizi.Exists(Veri(X, 1)) Then
                Dizi.Remove Veri(X, 1)
            End If
        Next
        
        ReDim Kriter(1 To Dizi.Count, 1 To 1)
        
        For Each Key In Dizi.Keys
            Say = Say + 1
            Kriter(Say, 1) = CStr(Key)
        Next
        
        If .AutoFilterMode = True Then .AutoFilterMode = False
        .Range("I2:I" & .Rows.Count).AutoFilter Field:=1, Criteria1:=Application.Transpose(Kriter), Operator:=xlFilterValues
    
        With S2.Cells(S2.Rows.Count, 5).End(3)(2, 1)
            .Resize(UBound(Kriter), 1) = Kriter
            .Offset(, 3).Resize(UBound(Kriter), 1) = "İlave"
        End With
        
        Application.ScreenUpdating = True
    
        MsgBox "I sütununda olup D sütununda olmayan değerler ;" & Chr(10) & Chr(10) & Join(Dizi.Keys, Chr(10))
    End With
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
End Sub

Sub Farkli_Olanlari_Goster_D_Sutunu()
    Dim Son_D As Long, Son_I As Long, Veri As Variant, X As Long
    Dim Kriter As Variant, Key As Variant, Say As Long
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Veri")
    Set S2 = Sheets("Sayfa1")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    With S1
        On Error Resume Next
        .ShowAllData
        On Error GoTo 0
    
        Son_D = .Range("D:D").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Son_I = .Range("I:I").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        
        Veri = .Range("D3:D" & Son_D).Value
    
        For X = LBound(Veri) To UBound(Veri)
            If Not Dizi.Exists(Veri(X, 1)) Then
                Dizi.Add Veri(X, 1), Nothing
            End If
        Next

        Veri = .Range("I3:I" & Son_I).Value
        
        For X = LBound(Veri) To UBound(Veri)
            If Dizi.Exists(Veri(X, 1)) Then
                Dizi.Remove Veri(X, 1)
            End If
        Next
        
        ReDim Kriter(1 To Dizi.Count, 1 To 1)
        
        For Each Key In Dizi.Keys
            Say = Say + 1
            Kriter(Say, 1) = CStr(Key)
        Next
        
        If .AutoFilterMode = True Then .AutoFilterMode = False
        .Range("D2:D" & .Rows.Count).AutoFilter Field:=1, Criteria1:=Application.Transpose(Kriter), Operator:=xlFilterValues
    
        With S2.Cells(S2.Rows.Count, 5).End(3)(2, 1)
            .Resize(UBound(Kriter), 1) = Kriter
            .Offset(, 3).Resize(UBound(Kriter), 1) = "Çıkan"
        End With
        
        Application.ScreenUpdating = True
    
        MsgBox "D sütununda olup I sütununda olmayan değerler ;" & Chr(10) & Chr(10) & Join(Dizi.Keys, Chr(10))
    End With
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
End Sub

nadirornek · 25 Eylül 2020

Emeğinize sağlık hata giderilmiştir.

MsgBox ile farklı olanları görmek

nadirornek

nadirornek

Ekli dosyalar

muygun

Özel Üye

Ekli dosyalar

ÖmerFaruk

Destek Ekibi

nadirornek

nadirornek

Ekli dosyalar

Korhan Ayhan

Administrator

nadirornek

nadirornek

Ekli dosyalar

Korhan Ayhan

Administrator

nadirornek

Korhan Ayhan

Administrator

nadirornek

nadirornek

Korhan Ayhan

Administrator

nadirornek

nadirornek

Korhan Ayhan

Administrator

nadirornek