Waarden interpoleren in een oppervlak met random geplaatste bekenden

Status
Niet open voor verdere reacties.
A

Antoonh

Gebruiker
Lid geworden
14 sep 2010
Berichten
20
Ik weet niet of dit uberhaupt opgelost kan worden in excel, ik zit er in ieder geval al een ochtendje over na te denken en kom er niet uit:

Ik heb in een coordinatenstelsel een paar coordinaten met een bekende diepte (zie vraag van een paar uur geleden), deze coordinaten zijn random in het stelsel geplaatst en dus niet alle diepten zijn bekend (het is een dieptekaart, de diepten zijn niet op gelijke afstanden van elkaar gemeten). Vanuit deze bekende diepten wil ik alle onbekende diepten invullen.

Dit kan natuurlijk op verschillende manieren, ik zit te denken aan een systeem waar driehoeken gemaakt worden tussen 3 verschillende coordinaten. Hier beginnen de problemen echter al, want hoe bepaal je welke driehoek je moet maken (in sommige gevallen zal de driehoek ook met een ander punt gemaakt kunnen worden), en om uit het vlak van de driehoek de andere coordinaten te berekenen is ook niet makkelijk (maar wel te doen denk ik).

Je zou misschien ook iets met vierkanten kunnen doen (het coordinatenstelsel is immers ook vierkant), maar omdat de coordinaten op random plaatsen zijn kun je vaak niet meteen een vierkant maken en moet je daar weer wat op verzinnen. (Ik heb al wel een methode om uit vier bekende diepten op de hoekpunten van een vierkant de diepte te bepalen in de rest van het vlak)

Ik hoop dat het een beetje duidelijk is, in de bijlage zit een simpel bestand ter verduidelijking.
 

Bijlagen

Hieronder een macro voor een simpele interpolate

speel er eens wat mee (neem rij 1 en kolom 1 niet mee voor het interpolatie gebied)

Code: 
Option Explicit
Sub Simple_interpolate()
Const app As String = "interpolate depth map"
Dim firstloop As Boolean
Dim VarDepth As Variant
Dim n As Long, i As Long, j As Long
Dim rMap As Range
Dim rDepth As Range
Dim OffsetCell As Range
Dim OffsetRange As Range
Dim Cell As Range
Dim Radius As Long


'radius of known cells to check around for empty cells
Radius = InputBox("which radius of the known coordinates do you want to fill out?", app, _
                    3)
'protect the user from ridiculous loops
If Radius > 15 Then Radius = 15

firstloop = True

For n = 1 To Radius
    
    If firstloop Then
    
        With Sheets("Ark1")
        
            On Error GoTo endof
                
                Set rMap = Application.InputBox("Select a Range (only the map, not the x,y coords)", _
                    app, , , , , , 8)
                VarDepth = rMap
                   
                Set rDepth = Application.InputBox("Select a single cell with a value inside the map", _
                    app, , , , , , 8)
                
                Do While rDepth.Cells.Count <> 1       'ensure the user selects a single cell
                    
                    MsgBox "Select a single cell!", vbExclamation, app
                    Set rDepth = Application.InputBox("Select a single cell with a value inside the map", _
                                                app, , , , , , 8)
                Loop
                
            On Error GoTo 0
        
        End With
    
    End If
    
    firstloop = False
    
    VarDepth = rMap
    With Sheets("Ark1")
    
        For i = LBound(VarDepth, 1) To UBound(VarDepth, 1)
            For j = LBound(VarDepth, 2) To UBound(VarDepth, 2)
                If VarDepth(i, j) <> Empty Then
                    Set rDepth = Union(rDepth, .Cells(i + 1, j + 1))
                End If
            Next
        Next

    End With

'rDepth.Select


    For Each Cell In rDepth
    
        'assign all cells around the current cell to a range
        Set OffsetRange = Range(Cell.Offset(-1, -1), Cell.Offset(1, 1))
        For Each OffsetCell In OffsetRange
            
            'the filled cells have been coloured
            If OffsetCell.Interior.ColorIndex <> 6 Then
                
                'check if the cell offset intersects with the Map
                If Not Intersect(OffsetCell, rMap) Is Nothing Then
                    
                    If OffsetCell <> Empty Then
                        OffsetCell = (OffsetCell + Cell) / 2
                    Else
                        OffsetCell = Cell
                    End If
                    
                    'mark this cell as used
                    OffsetCell.Interior.ColorIndex = 6
                End If
            
            End If
        
        Next OffsetCell
          
    Next Cell

Next n

endof:
Select Case Err.Number
    Case 424  ' user did not give a range, so we assume quit

    Case 13
        MsgBox "Please enter a number between 1 and 15"
        Resume
End Select

Set rMap = Nothing
Set rDepth = Nothing
Set OffsetRange = Nothing
End Sub
 
Ik denk dat mijn bovenstaande idee niet mogelijk is in excel (en anders wordt het waarschijnlijk vrij complex). Ik heb nu iets nieuws bedacht, iets minder nauwkeurig, maar ik denk dat het werkt.

Alle waarden die in dezelfde rij of kolom staan worden lineair geinterpoleerd als de afstand niet meer dan, zeg 10, cellen beslaat. Met deze nieuwe waarden kunnen dan weer nieuwe interpolaties worden gemaakt met andere bekende waarden. In de bijgevoegde excelsheet probeer ik het een beetje duidelijk te maken dmv kleuren. Eerst worden de rode cellen berekend met de waarden die op een lijn, en niet te ver uit elkaar staan. Met deze nieuwe bekende cellen kunnen weer andere lijnen worden berekend, in dit geval de gele, met de gele worden dan weer de blauwe berekend, dan de groene, enz.

Als de afstand waarover lineair mag worden geinterpoleerd variabel wordt gemaakt, dan moet er voor een afstand die groot genoeg is een flink stuk van de onbekende waarden worden gevonden.

Duidelijk? :P Ik doe mijn best....

Veeeeeel respect voor degene die dit oplost! Misschien kan je er ook excel-Mondriaans mee maken als je alle cellen kleurtjes geeft...

Edit:

Was aan het typen toen je je reactie plaatste, ik ga het even bekijken!
 

Bijlagen

Laatst bewerkt:
hierdezelfde code met kleurindicatie. dat maakt het nog duidelijker

Code: 
Option Explicit
Sub Simple_interpolate()
Const app As String = "interpolate depth map"
Dim firstloop As Boolean
Dim VarDepth As Variant
Dim n As Long, i As Long, j As Long
Dim rMap As Range
Dim rDepth As Range
Dim OffsetCell As Range
Dim OffsetRange As Range
Dim Cell As Range
Dim Radius As Long

'radius of known cells to check around for empty cells
Radius = InputBox("which radius of the known coordinates do you want to fill out?", app, _
                    3)
'protect the user from ridiculous loops
If Radius > 15 Then Radius = 15

firstloop = True

For n = 1 To Radius
    
    If firstloop Then
    
        With Activesheet
        
            On Error GoTo endof
                
                Set rMap = Application.InputBox("Select a Range (only the map, not the x,y coords)", _
                    app, , , , , , 8)
                VarDepth = rMap
                   
                Set rDepth = Application.InputBox("Select a single cell with a value inside the map", _
                    app, , , , , , 8)
                
                Do While rDepth.Cells.Count <> 1       'ensure the user selects a single cell
                    
                    MsgBox "Select a single cell!", vbExclamation, app
                    Set rDepth = Application.InputBox("Select a single cell with a value inside the map", _
                                                app, , , , , , 8)
                Loop
                
            On Error GoTo 0
        
        End With
    
    End If
    
    firstloop = False
    
    VarDepth = rMap
    With Activesheet
    
        For i = LBound(VarDepth, 1) To UBound(VarDepth, 1)
            For j = LBound(VarDepth, 2) To UBound(VarDepth, 2)
                If VarDepth(i, j) <> Empty Then
                    Set rDepth = Union(rDepth, .Cells(i + 1, j + 1))
                End If
            Next
        Next

    End With

'rDepth.Select


    For Each Cell In rDepth
    
        'assign all cells around the current cell to a range
        Set OffsetRange = Range(Cell.Offset(-1, -1), Cell.Offset(1, 1))
        For Each OffsetCell In OffsetRange
            
            'the filled cells have been coloured
            If OffsetCell.Interior.ColorIndex <> 6 Then
                
                'check if the cell offset intersects with the Map
                If Not Intersect(OffsetCell, rMap) Is Nothing Then
                    
                    If OffsetCell <> Empty Then
                        OffsetCell = (OffsetCell + Cell) / 2
                    Else
                        OffsetCell = Cell
                    End If
                    
                    'mark this cell as used
                    OffsetCell.Interior.ColorIndex = 6
                End If
            
            End If
        
        Next OffsetCell
          
    Next Cell

Next n

Call colormap(rMap)

endof:
Select Case Err.Number
    Case 424  ' user did not give a range, so we assume quit

    Case 13
        MsgBox "Please enter a number between 1 and 15"
        Resume
End Select

Set rMap = Nothing
Set rDepth = Nothing
Set OffsetRange = Nothing
End Sub
Sub colormap(ByRef MapRange As Range)
Dim lmin As Long, lmax As Long, lrange As Long
Dim Cell As Range

With WorksheetFunction
    lmin = .Min(MapRange)
    lmax = .Max(MapRange)
End With

lrange = lmax - lmin

On Error GoTo blackout
For Each Cell In MapRange
    Cell.Interior.Color = RGB(255 - ((255 / lrange) * (Cell.Value - lmin)), _
                            255 - ((255 / lrange) * (Cell.Value - lmin)), 255)
Next
On Error GoTo 0
blackout:
If Err.Number = 11 Then
    Cell.Interior.Color = 0
    Resume Next
End If
End Sub
 
Laatst bewerkt:
Antoonh,

Ik heb de code even in een bestand gezet met knoppen erbij.
ook is de code nog iets aangepast t.o.v. de geposte code.

ook had ik de x,y omgedraaid in de code in de vorige thread.
Ik heb dat meteen ook even gefixt.

Kijk maar of je er iets mee kan, laat het maar weten.
 

Bijlagen

Dit ziet er wel echt heel goed uit! Hier kan ik zeker wat mee :) Ik heb gisteren geen tijd meer gehad om er echt naar te kijken, maar 1 dingetje viel me wel op: Volgens mij moet je de VBA vaker runnen om echt de 'linearisering' te krijgen, dat is natuurlijk niet erg, maar omdat de offsetcell boven de gewone cell ligt wordt (in dit voorbeeld) de gemiddelde waarde elke keer iets hoger. De gemiddelde waarde zou 'tussen' twee cellen moeten liggen, en hij wordt nu in cell gezet. Ik denk dat dit wel op te lossen is door de hele VBA te loopen, en dan de offsetcell de ene keer onder en de andere keer boven de cell te pakken, bv met -1^(i). Ik ga er zo weer verder naar kijken en dan probeer ik het uit te vogelen.

Bedankt voor het uitgebreide antwoord!
 
Laatst bewerkt:
Code: 
'assign all cells around the current cell to a range
        Set OffsetRange = Range(Cell.Offset(-1, -1), Cell.Offset(1, 1))

Ik snap niet helemaal wat hier gebeurt, je zegt alle cellen rond de geselecteerde cel, maar als ik hem run dan neemt ie volgens mij niet alle cellen, maar alleen een cel linksboven de cel? Het is een beetje moeilijk te volgen voor mij, sorry!

Edit:

Ik snap nu wel wat de code doet, maar als ik hem run lijkt het alsof hij alleen lineariseert van linksboven naar rechtsonder...
 
Laatst bewerkt:
Antoon,

Een For..each next loop met celbereik neemt altijd eerst de cel linksboven en vervolgens de cel daarnaast, totdat de hele rij van het betreffende bereik is doorlopen, dan begint de volgende rij. Dus dan is inderdaad te verwachten dat de macro (in ieder geval enigszins)lineariseert van linksboven naar rechtsonder.

Als je trouwens dmv handmatig interpoleren wat extra waarden in je oppervlak gooit, kom je waarschijnlijk tot een naukeuriger resultaat, waarbij je de macro je werk laat afmaken.
 
Ik heb het nu anders gedaan; vanuit de omliggende waarden bereken ik de celwaarde zelf, dit is een stuk stabieler. De bijgevoegde file is een rommeltje, ik wilde er vanavond verder aan gaan werken, maar dan kun je zien hoe ik het nu doe. Omdat ik niet veel ervaring heb met VBA (ongeveer 2 weken) ziet de code er waarschijnlijk wat amateuristisch uit :P misschien heb je nog wat tips om de code beter te maken?

Er moeten nog een paar dingen in:
- De randen van de range worden nu niet goed meegenomen in het berekenen van het gemiddelde. Er staat nu 'totale waarde/9', die 9 moet het aantal cellen zijn in de Intersection van de OffsetRange en rMap. Ik weet nog niet hoe dat moet.
- De begincoordinaten zouden eigenlijk vast moeten staan, zodat ze nooit veranderen. Dan wordt de oplossing nog beter. Ik weet ook niet hoe ik dat zou kunnen doen.
 

Bijlagen

Laatst bewerkt:
Antoon

Ik heb je code even aangepast

VBA is niet zo moeilijk om te leren, ik werk er nu een jaartje mee, en heb verder geen programmeer ervaring.
Hoe moeilijker de uitdaging hoe meer je leert zeg ik altijd maar.!

Ik heb de berekening van het gemiddelde van de cellen aan de loop toegevoegd. kijk maar even of je snapt hoe het werkt.
Je kunt een variabele bij zichzelf optellen
bijvoorbeeld :
Code: 
Sub test()
Dim y as Long
y = 1
y = y + 1 
y = y + 2 
MsgBox y
 

Bijlagen

Ik probeer nu de coordinaten die in het stelsel worden gezet een achtergrondkleur mee te geven. In ark2 worden deze waarden dan herkend en niet meegenomen als de cellen nieuwe waarden krijgen. In ark2 werkt het, in ark1 lukt het me niet om de waarden die achtergrondkleur mee te geven. Ik heb nu dit:

Code: 
Private Sub CommandButton1_Click()
    fyld_depth
End Sub
Sub fyld_depth()
Dim vArk1 As Variant
Dim vArk2 As Variant
Dim XArk2 As Variant
Dim YArk2 As Variant
Dim rArk2 As Range
Dim xCord As Object, yCord As Object
Dim i As Long, j As Long


vArk1 = Sheets("Ark1").UsedRange 'Hent Ark 1 og Ark 2

With Sheets("Ark2")
    .Range("A1") = 0
    vArk2 = .UsedRange
    XArk2 = .Range("A1", .Range("IV1").End(xlToLeft))
    YArk2 = .Range("A1", .Range("A65535").End(xlUp))
End With

'Søg X, Y
Set xCord = CreateObject("Scripting.dictionary")
Set yCord = CreateObject("Scripting.dictionary")

For i = 1 To UBound(XArk2, 2)
    xCord.Add CStr(XArk2(1, i)), i
Next
For i = 1 To UBound(YArk2, 1)
    yCord.Add CStr(YArk2(i, 1)), i
Next

For i = 2 To UBound(vArk1)  'fyld matrix x,y
    
    On Error Resume Next    'hvis  x ,y findes ikke
    vArk2(yCord(CStr((vArk1(i, 2)))), xCord(CStr(vArk1(i, 1)))) = vArk1(i, 3)
    
Next

'opdater Ark2 med nye værdier
Sheets("Ark2").Range("A1").Resize(UBound(vArk2, 1), UBound(vArk2, 2)) = vArk2

[B][COLOR="sienna"]With Sheets("Ark2")

For i = 1 To UBound(XArk2, 2)
    For j = 1 To UBound(YArk2, 1)
        If vArk2(i, j) <> Empty Then
            If rArk2 Is Nothing Then Set rArk2 = .Cells(i, j)
            Set rArk2 = Union(rArk2, .Cells(i, j))
        End If
    Next j
Next i

End With

Set Sheets("Ark2").rArk2.Interior.ColorIndex = 3[/COLOR][/B]

Set xCord = Nothing
Set yCord = Nothing

End Sub

Het dikgedrukte stuk heb ik erbij gezet, en dit werkt niet. Ik probeer de cellen die een waarde hebben in een range te zetten, en dan die hele range een achtergrondkleur te geven. Hoe moet ik dat doen?
 
Laatst bewerkt:
Een van de dingen die je leert terwijl je met VBA speelt is dat Excel zeer krachtige functies heeft die veel sneller zijn dan bv een dubbele for..next loop

Kijk maar eens naar onderstaande code
Code: 
Sub fyld_depth()
Dim vArk1 As Variant
Dim vArk2 As Variant
Dim XArk2 As Variant
Dim YArk2 As Variant
Dim rArk2 As Range
Dim xCord As Object, yCord As Object
Dim i As Long, j As Long


vArk1 = Sheets("Ark1").UsedRange 'Hent Ark 1 og Ark 2

With Sheets("Ark2")
    .Range("A1") = 0
    vArk2 = .UsedRange
    XArk2 = .Range("A1", .Range("IV1").End(xlToLeft))
    YArk2 = .Range("A1", .Range("A65535").End(xlUp))
End With

'Søg X, Y
Set xCord = CreateObject("Scripting.dictionary")
Set yCord = CreateObject("Scripting.dictionary")

For i = 1 To UBound(XArk2, 2)
    xCord.Add CStr(XArk2(1, i)), i
Next
For i = 1 To UBound(YArk2, 1)
    yCord.Add CStr(YArk2(i, 1)), i
Next

For i = 2 To UBound(vArk1)  'fyld matrix x,y
    
    On Error Resume Next    'hvis  x ,y findes ikke
    vArk2(yCord(CStr((vArk1(i, 2)))), xCord(CStr(vArk1(i, 1)))) = vArk1(i, 3)
    
Next

[COLOR="green"]'opdater Ark2 med nye værdier[/COLOR]

[COLOR="darkred"]With Sheets("Ark2").Range("A1").Resize(UBound(vArk2, 1), UBound(vArk2, 2))
    .Interior.Colorindex = xlNone  'reset colors
    .Value = vArk2
    .Cells.SpecialCells(xlCellTypeConstants).Interior.ColorIndex = 3
End With[/COLOR]

Set xCord = Nothing
Set yCord = Nothing

End Sub

Ik heb ook de oude code even aangepast. in de haast had ik daar ook een loop ingezet wat niet nodig was. zie bijlage.
 

Bijlagen

Laatst bewerkt:
Zo is het inderdaad een stuk makkelijker, in ark2 werkt het goed, in ark1 wil ik echter iets anders bereiken. Ik wil de coordinaten die daar staan gegeven in een range zetten. Dan kan ik die range een kleur geven. Dat is handig als je de interpolatie vaker dan 1 keer wilt runnen. Als je nu de waarden in het stelsel zet, en dan de interpolatie runt dan gaat het goed, maar ik wil dezelfde waarden nu opnieuw in het stelsel zetten (lees:een achtergrondkleur geven), zodat ze niet veranderen. Als je dit de tweede keer doet en er staan al andere waarden in ark2, dan worden die allemaal gekleurd, en dus allemaal vast.

Eigenlijk moet de range dus rechtstreeks uit de coordinaten worden gehaald. Ik snap alleen van het coordinatenverhaaltje in ark1 niet zo veel, dus ik kom er nog niet uit...
 
Hier de code, met wat uitleg
Code: 
Option Explicit
Sub fyld_depth2()
Dim vArk1 As Variant
Dim vArk2 As Variant
Dim XArk2 As Variant
Dim YArk2 As Variant
Dim rArk2 As Range
Dim xCord As Object, yCord As Object
Dim i As Long, j As Long

'Zet Het gebruikte bereik van  Ark 1 in een Array (Matrix in het geheugen)
vArk1 = Sheets("Ark1").UsedRange

With Sheets("Ark2")
    
    .Range("A1") = 0
    
    'Zet Het gebruikte bereik van  Ark 2 in een Array
    vArk2 = .UsedRange
    'een matrix die de X coordinaten in Ark2 bevat
    XArk2 = .Range("A1", .Range("IV1").End(xlToLeft))
    'een matrix die de Y coordinaten in Ark2 bevat
    YArk2 = .Range("A1", .Range("A65535").End(xlUp))
End With

'Maak een dictionary Object aan:
' een dictionary koppelt een Key aan een waarde.. in dit geval _
    wordt een Coordinaat op de X of Y as gekoppeld aan Kolom of rijnummer

Set xCord = CreateObject("Scripting.dictionary")        'waarden op de X as
Set yCord = CreateObject("Scripting.dictionary")        'waarden op de Y as

For i = 1 To UBound(XArk2, 2)
    
    'Cstr = waarde omzetten in tekst, anders werkt de dictionary key niet goed
    
    xCord.Add CStr(XArk2(1, i)), i      'voeg waarde to aan dictionary _
                                        Key = Coordinaat, Value = Kolomnummer _

Next
For i = 1 To UBound(YArk2, 1)           'voeg waarde to aan dictionary _
                                        Key = Coordinaat, Value = Rijnummer
    
    'Cstr = waarde omzetten in tekst, anders werkt de dictionary key niet goed
    yCord.Add CStr(YArk2(i, 1)), i
Next

For i = 2 To UBound(vArk1)  'Vullen matrix Ark2 met informatie uit ARk1 _
                            d.w.z. de tabel in Ark 1
    
    'omdat de X en Y coordinaten via de dictionary direct naar rij en kolomnummers _
    worden omgezet kan de juiste positie in matrix vArk2 direct worden voorzien van _
    een nummer
    On Error Resume Next    'hvis  x ,y findes ikke
    
    '   yCord(CStr(vArk1(i, 2))) zoekt de waarde van vArk1(i,2) in yCord
    '           yCord geeft het rijnummer terug, idem voor xCord
    vArk2(yCord(CStr(vArk1(i, 2))), xCord(CStr(vArk1(i, 1)))) = vArk1(i, 3)
    
Next

'Bewerkte Matrix terugplaatsen in Ark2
With Sheets("Ark2").Range("A1").Resize(UBound(vArk2, 1), UBound(vArk2, 2))
    .Interior.ColorIndex = xlNone       'reset colors
    .Value = vArk2
    .Cells.SpecialCells(xlCellTypeConstants).Interior.ColorIndex = 3
End With

Set xCord = Nothing
Set yCord = Nothing

End Sub
 
Ik heb het nu zo gedaan dat de diepten die in het stelsel worden gezet een andere font kleur hebben, in de 'interpolate map' sheet zeg ik dan dat de cellen met die font kleur niet aangepast worden. Het werkt perfect nu :)

Heel erg bedankt voor de vele hulp! Ik waardeer het echt dat je me hier doorheen hebt geholpen :)
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan