Min ve Max olarak yeni konu açtım Sayın @berduş bey.
yyhy, 18-05-2009 tarihinden beri AccessTr.neT üyesidir.
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
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