Skip to main content

AccessTr.neT


Birime Göre En Büyük Değer İle En Küçük Değer Arasındaki Eksik Sayılar Listesi

Birime Göre En Büyük Değer İle En Küçük Değer Arasındaki Eksik Sayılar Listesi

#13
Min ve Max olarak yeni konu açtım Sayın @berduş bey.
yyhy, 18-05-2009 tarihinden beri AccessTr.neT üyesidir.
Cevapla
#14
dilerim işinize yarar
Sub EksikBul()
SonStr = Cells(Rows.Count, "AF").End(xlUp).Row
If SonStr < 2 Then SonStr = 2

Range("AF2:AF" & SonStr).ClearContents

Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextCompare
SonStr = Cells(Rows.Count, "B").End(xlUp).Row
For x = 3 To SonStr
dgr = Trim(Cells(x, 2))
If dgr <> "" Then If Dict.Exists(dgr) = True Then Dict(dgr) = Dict(dgr) & "," & Cells(x, 3) Else Dict.Add dgr, Cells(x, 3)
Next x

Dim key As Variant
i = 0
If Dict.Count < 1 Then Exit Sub
For Each key In Dict.Keys
Dim SyfAktr() As Variant
xDz = Evaluate("{" & Dict(key) & "}")
xMin = WorksheetFunction.Min(xDz)
xMax = WorksheetFunction.Max(xDz)
xdKey = "," & Dict(key) & ","
For xXL = xMin + 1 To xMax - 1
VarMi = InStr(1, xdKey, "," & xXL & ",")
If VarMi = 0 Then
ReDim Preserve SyfAktr(i)
SyfAktr(UBound(SyfAktr)) = key & " " & xXL
i = i + 1
End If
Next xXL
Next key

j = 0 'transpose
ReDim SonDizi(LBound(SyfAktr) To UBound(SyfAktr), 0)
For j = LBound(SyfAktr) To UBound(SyfAktr)
SonDizi(j, 0) = SyfAktr(j)
Next j

Range("AF2").Resize(UBound(SyfAktr) + 1).Value = SonDizi ' Application.Transpose(SyfAktr)
End Sub
.rar Min_Max_Arası_EksikSayı_hy2.rar (Dosya Boyutu: 85,92 KB | İndirme Sayısı: 2)
Cevapla
#15
B ve C sütunlarındaki veri değişince kod çalışır
Cevapla
#16
Sayın @berduş bey B sütununa veri yazıp C sütununa geçince resmini attığım hatayı veriyor. Resim içindeki hata kodunda end deyip geçiyorum. Bunu düzeltebilir miyiz?
Yapılan işlem güzel.
yyhy, 18-05-2009 tarihinden beri AccessTr.neT üyesidir.
Son Düzenleme: 21/09/2021, 21:54, Düzenleyen: yyhy.
Cevapla
#17
kodu düzenledim dener misiniz?
sadece kırmızı denetleme kodu eklendi
If dgr <> "" And Trim(Cells(x, 3)) <> "" Then If Dict.Exists(dgr) = True Then Dict(dgr) = Dict(dgr) & "," & Cells(x, 3) Else Dict.Add dgr, Cells(x, 3)
Sub EksikBul()
SonStr = Cells(Rows.Count, "AF").End(xlUp).Row
If SonStr < 2 Then SonStr = 2

Range("AF2:AF" & SonStr).ClearContents

Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = vbTextCompare
SonStr = Cells(Rows.Count, "B").End(xlUp).Row
For x = 3 To SonStr
dgr = Trim(Cells(x, 2))
    If dgr <> "" And Trim(Cells(x, 3)) <> "" Then If Dict.Exists(dgr) = True Then Dict(dgr) = Dict(dgr) & "," & Cells(x, 3) Else Dict.Add dgr, Cells(x, 3)
Next x

Dim key As Variant
i = 0
If Dict.Count < 1 Then Exit Sub
For Each key In Dict.Keys
Dim SyfAktr() As Variant
xDz = Evaluate("{" & Dict(key) & "}")
xMin = WorksheetFunction.Min(xDz)
xMax = WorksheetFunction.Max(xDz)
xdKey = "," & Dict(key) & ","
    For xXL = xMin + 1 To xMax - 1
    VarMi = InStr(1, xdKey, "," & xXL & ",")
        If VarMi = 0 Then
        ReDim Preserve SyfAktr(i)
                SyfAktr(UBound(SyfAktr)) = key & " " & xXL
        i = i + 1
        End If
    Next xXL
Next key

j = 0 'transpose
    ReDim SonDizi(LBound(SyfAktr) To UBound(SyfAktr), 0)
        For j = LBound(SyfAktr) To UBound(SyfAktr)
            SonDizi(j, 0) = SyfAktr(j)
        Next j

Range("AF2").Resize(UBound(SyfAktr) + 1).Value = SonDizi ' Application.Transpose(SyfAktr)
End Sub
Cevapla
#18
Sayın @berduş bey AF sütunu son makro ile güzel çalışıyor. Emeğinize sağlık.

Acaba D sütunu için de ayrı bir makro hazırlanabilir mi? Dosyayı da son şekli ile ekledim.
.rar Min_Max_Arası_EksikSayı_hy2 - 02.rar (Dosya Boyutu: 80,56 KB | İndirme Sayısı: 3)
yyhy, 18-05-2009 tarihinden beri AccessTr.neT üyesidir.
Son Düzenleme: 21/09/2021, 23:40, Düzenleyen: yyhy.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da