Maatdata

[Harheld]

Hallo ik ben aan het stoeien met meetdata omdeze netjes in Excel te zetten.

Ik wil hier een macro van maken aangezien het nu een hoop knip en plak werk is.

Voorbeeld:
Dit:
[table="width: 500, class: dotted"][tr][td]METING NAAM [/td][td][/td][td] [/td][/tr]
[tr][td] [/td][td] [/td][td]1[/td][/tr]
[tr][td]Object [/td][td]Info [/td][td]Maat[/td][/tr]
[tr][td]X [/td][td]a [/td][td]1.1[/td][/tr]
[tr][td]DIA [/td][td]b [/td][td]4.2[/td][/tr]
[tr][td]Y [/td][td]c [/td][td]3.6[/td][/tr]
[tr][td]METING NAAM [/td][td][/td][/tr]
[tr][td] [/td][td] [/td][td]2[/td][/tr]
[tr][td]Object [/td][td]Info [/td][td]Maat[/td][/tr]
[tr][td]X [/td][td]a [/td][td]1.6[/td][/tr]
[tr][td]DIA [/td][td]b [/td][td]5.2[/td][/tr]
[tr][td]Y [/td][td]c [/td][td]8.7[/td][/tr]
[tr][td]METING NAAM [/td][td][/td][/tr]
[tr][td] [/td][td] [/td][td]3[/td][/tr]
[tr][td]Object [/td][td]Info [/td][td]Maat[/td][/tr]
[tr][td]X [/td][td]a [/td][td]1.2[/td][/tr]
[tr][td]DIA [/td][td]b [/td][td]3.6[/td][/tr]
[tr][td]Y [/td][td]c [/td][td]6.1[/td][/tr]
[/table]

Moet dit worden:
[table="width: 500, class: dotted"][tr][td]METING NAAM[/td][td] [/td][td] [/td][td] [/td][td] [/td][/tr]
[tr][td] [/td][td] [/td][td]1 [/td][td]2 [/td][td]3[/td][/tr]
[tr][td]Object [/td][td]Info [/td][td]Maat [/td][td]Maat [/td][td]Maat[/td][/tr]
[tr][td]X [/td][td]a [/td][td]1.1 [/td][td]1.6 [/td][td]1.2[/td][/tr]
[tr][td]DIA [/td][td]b [/td][td]4.2 [/td][td]5.2 [/td][td]3.6[/td][/tr]
[tr][td]Y [/td][td]c [/td][td]3.6 [/td][td]8.7 [/td][td]6.1[/td][/tr]
[/table]

Op het moment heb ik de volgende code:

Sub Zoekkopier()
Dim Zoeka
Dim Zoekb
Dim Rija
Dim Rijb
Dim Kol


    Kol = D
    Zoekb = "1"
    Zoekk = Range("A1")
    Zoeka = WorksheetFunction.CountIf(Range("A:A"), Zoekk)
    
    Range("A:A").Activate
    MsgBox Zoekk & " " & Zoeka
        Cells.Find(What:=Zoekk, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    Cells.FindNext(After:=ActiveCell).Activate
    Rija = ActiveCell.Row
    
    
    Cells.FindNext(After:=ActiveCell).Activate
    Rijb = ActiveCell.Row
    Range("C" & Rija & ":C" & Rijb).Activate
    
    
    'Range("D1").PasteSpecial xlValues
    
End Sub

Ik ben begonnen met het laten zoeken naar waar meting 2 begint en eindigt om zo meting 2 te kopiëren naar D1, maar het lukt me niet om de juiste range te selecteren en deze te kopiëren.
Als dit me gelukt is wil ik een loop inbouwen zodat hij het aantal meting wat aanwezig is kopieert.

Mijn vraag:
Hoe krijg ik dat kopiëren voor elkaar?
Hebben jullie misschien nog tips?

 

[Harheld]

Meetdata

Hmm zie nu dat ik de titel Maatdata genoemd heb...