Ortak sayilari bulma konusunda yardim !

[alikirca20]

Arkadaslar benim amacim farkli sayi gruplari icerisinde en fazla ortak olan 4, 5 veya uzeri sayiyi bulabilmek.

mesela: asagidaki 4 sayi grubunda en fazla ortak olan 3 sayi (10-15-16) dir.

4-9-10-15-16
6-10-15-23-16
10-15-75-54-16
25-38-49-55-71

Bu amacla yabanci sitelerde bir arama yaptim ve asagidaki tarzda bir makroya ulastim:

Benim merak ettigim ilkin bu makronun dogru calisip calismadigi ikinci olarak da sayet elimizde yukardaki ornekte oldugu gibi 5 erli degil de cok daha fazla sayidan olusan gruplar olursa (ornegin 20 sayidan) ayni sekilde bu gruplar icerisinde de en fazla ortak olan 5 veya daha fazla sayiyi `makro` yardimiyla bulmamiz mumkun mudur? asagidaki makro buna uyarlanabilir mi? yardimci olabilirseniz cok sevinirim.

sitenin adresi: http://www.tech-archive.net/Archive/.../msg01796.html


Sub MostCommonPair()
Dim rng As Range
Dim c As Range
Dim strPair As String
Dim ws As Work***
Dim lRow As Long
Dim lRow2 As Long
Dim lCount As Long

Set rng = Intersect(Active***.UsedRange, Active***.Range("A:F"))

Application.ScreenUpdating = False
Application.DisplayAlerts = False

If Not rng Is Nothing Then
Set ws = ActiveWorkbook.Worksheets.Add
lRow = 1
For Each c In rng
If c.Column <= 5 Then
strPair = c.Value & "_" & c.Offset(0, 1).Value

On Error Resume Next
lRow2 = Application.WorksheetFunction.Match(strPair,
ws.Range("A:A"), False)
If Err.Number > 0 Then
ws.Range("A" & lRow).Value = strPair
ws.Range("B" & lRow).Value = 1
lRow = lRow + 1
Else
ws.Range("B" & lRow2).Value = ws.Range("B" &
lRow2).Value + 1
End If
On Error GoTo 0
End If
Next c
End If

'get the one with largest count
With Application.WorksheetFunction
lCount = .Large(ws.Range("B:B"), 1)
lRow = .Match(lCount, ws.Range("B:B"), False)
End With
MsgBox "Most Common Pair is " & ws.Range("A" & lRow) & " (" & lCount & "
occurrences)"

ws.Delete

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Sub MostCommonTriplet()
Dim rng As Range
Dim c As Range
Dim strTriplet As String
Dim ws As Work***
Dim lRow As Long
Dim lRow2 As Long
Dim lCount As Long

Set rng = Intersect(Active***.UsedRange, Active***.Range("A:F"))

Application.ScreenUpdating = False
Application.DisplayAlerts = False

If Not rng Is Nothing Then
Set ws = ActiveWorkbook.Worksheets.Add
lRow = 1
For Each c In rng
If c.Column <= 4 Then
strTriplet = c.Value & "_" & c.Offset(0, 1).Value & "_" &
c.Offset(0, 2).Value

On Error Resume Next
lRow2 = Application.WorksheetFunction.Match(strTriplet,
ws.Range("A:A"), False)
If Err.Number > 0 Then
ws.Range("A" & lRow).Value = strTriplet
ws.Range("B" & lRow).Value = 1
lRow = lRow + 1
Else
ws.Range("B" & lRow2).Value = ws.Range("B" &
lRow2).Value + 1
End If
On Error GoTo 0
End If
Next c
End If

'get the one with largest count
With Application.WorksheetFunction
lCount = .Large(ws.Range("B:B"), 1)
lRow = .Match(lCount, ws.Range("B:B"), False)
End With
MsgBox "Most Common Triplet is " & ws.Range("A" & lRow) & " (" & lCount
& " occurrences)"

ws.Delete

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

 

[serseri26]

uzman arkadaşların yadımlarını bekliyoruz

 

[serseri26]

fikri olan akradaşlardamı yok