I hope you know a bit of vba..it may look a bit complex but
when broken down it's not that difficult.
Be aware that the permutations grow very fast...
100 objects.. 900 permuts
1000 objects .. 999000 permuts!
also note that the ObjID's in column A must be unique.
(otherwise use the rowNr of the object as key)
<VBG
the strings are parsed in the LocParse function.
to create an array of coordinates.
(missing coord are added as .01)
pls review the wisdom of that :)
instead of constantly redimming arrays...
I like to store stuff in dictionaries :)
so i store all the coord's in 1 dictionary.
then i start comparing that dictionary against itself.
and the (keys) of the positive results are then stored
in another dictionary.
when done..I write the results to a range.
'Code requires a reference to "Microsoft scripting runtime"
Option Explicit
Const x = 1
Const y = 2
Const w = 3
Const h = 4
Sub CompareObjects()
Dim rngData As Range, rngDump As Range
Dim dicData As Scripting.Dictionary
Dim dicTrue As Scripting.Dictionary
Dim vItms As Variant
Dim vKeys As Variant
Dim i&, j&, n&
Set rngData = Range(Cells(2, 1), Cells(Rows.Count, _
1).End(xlUp))
Set dicData = GetData(rngData)
Set dicTrue = New Scripting.Dictionary
'Get data from dictionary
vItms = dicData.Items
vKeys = dicData.Keys
'Compare all permutations
For i = LBound(vItms) To UBound(vItms)
For j = LBound(vItms) To UBound(vItms)
If i < j Then
If IsInside(vItms(i), vItms(j)) Then
dicTrue.Add vKeys(i) & vbTab & vKeys(j), Null
End If
End If
Next
Next
If dicTrue.Count = 0 Then
MsgBox "No objects inside other"
Else
Set rngDump = Application.InputBox( _
dicTrue.Count & " objects inside other" & vbLf & _
"Select a range to dump the results", Type:=8)
rngDump.Resize(dicTrue.Count) = _
Application.Transpose(dicTrue.Keys)
rngDump.Resize(dicTrue.Count).TextToColumns _
rngDump, , , , -1, 0, 0, 0, 0, 0
End If
End Sub
Function GetData(rData As Range) As Scripting.Dictionary
Dim d As Scripting.Dictionary
Dim rObjID As Range
Dim aCoord As Variant
'Note objectID's must be unique
Set d = New Scripting.Dictionary
d.CompareMode = BinaryCompare
For Each rObjID In rData.Columns(1).Cells
With rObjID
If Len(.Value) Then
If Not d.Exists(.Value) Then
aCoord = LocParse(.Cells(1, 2).Value)
d.Add .Value, aCoord
End If
End If
End With
Next
Set GetData = d
End Function
Function LocParse(ByVal sLoc$)
'splits a location string into an array
'of its components
Dim vaRes(1 To 5), n&, p1&, p2&, vFind
sLoc = LCase(sLoc & " ")
For Each vFind In Array("x:", "y:", "w:", "h:", "index:")
n = n + 1
p1 = InStr(1, sLoc, vFind)
If p1 Then
p1 = p1 + Len(vFind)
p2 = InStr(p1, sLoc, " ")
vaRes(n) = Val(Mid(sLoc, p1, p2 - p1))
Else
vaRes(n) = 0.01
End If
Next
LocParse = vaRes
End Function
Function IsInside(OuterC, InnerC) As Boolean
'Returns True if InnerC is fully within OuterC
'Input arguments must be coordinate arrays
If InnerC(x) = OuterC(x) Then
If InnerC(y) = OuterC(y) Then
If InnerC(x) + InnerC(w) <= OuterC(x) + OuterC(w) Then
If InnerC(y) + InnerC(h) <= OuterC(y) + OuterC(h) Then
IsInside = True
End If
End If
End If
End If
End Function
--
keepITcool
|
www.XLsupport.com | keepITcool chello nl | amsterdam
popovsky wrote :
Get and compare numbers
I would really appreciate if you would help me out with this:
i have a couple of sheets with colums containing names and coordinates
of objects. as text.
something like this:
in column A : names of objects.
in column B : coordinates as a text field with the folowing
formatting:
A B
SEA 'coord x:4.50cm y:27.50cm w:21.12cm h:28.87cm index:2
(+some values can be missing.. for ex :SHIP coord x:11.50cm y:32.00cm
h:2.08cm index:40)
i need to compute the following :
for each object i gotta find out if it inside the coordinates of
another object.
Like this:
we take X value (lets call it x1) of one object and compare to other
object's values of X (lets call it x2) and X+W (lets call it XW).
if x2<x1<xw and y2<y1<yh (same thing for vertical) then the object is
inside and i need a msgbox saying : SHIP is inside SEA.
THANX. I really appreciate your help.