flytning af kolonne ud fra en værdi

er tallene i kolonne 1 altid stigende

er tallene i kolonne 1 altid stigende
og kolonne 2 også

Ja

Sub FindNærmeste()
Dim F As Variant, N As Integer, H1 As Integer, I As Integer, H As Variant, T As Integer
On Error Resume Next
F = Range("A2:C8") ' ret til dit område incl. den tomme kolonne der skal skrives i

    For I = 1 To UBound(F)
    H1 = 0
    H = 100
      For N = 1 To UBound(F)
     
      If F(I, 1) <> "" And F(N, 2) <> "" Then
     
          If F(N, 2) > F(I, 1) And F(N, 2) - F(I, 1) < H Then
            H = F(N, 2) - F(I, 1)
            H1 = N
          End If
         
          If F(N, 2) < F(I, 1) And F(I, 1) - F(N, 2) < H Then
            H = F(I, 1) - F(N, 2)
            H1 = N
          End If
         
      End If
     
      Next
     
        F(I, 3) = F(H1, 2)
        F(H1, 2) = ""
       
        If I = 1 Then
            For T = 1 To UBound(F)
                If F(T, 2) < F(I, 3) Then
                    F(T, 2) = ""
                End If
            Next
      End If
    Next
   
Range("A2:C8") = F ' ret til dit område incl. den tomme kolonne der skal skrives i

End Sub

Skal det ind i dit visual basic program fra tidligere. ?
Data står i et ark: Deling af data
kolonne 1: C2-C70
kolonne 2: D2-D70
Kolonne 3: E2-E70

Jeg prøver at sætte ind i tidligere program, men der skal i dette program stå et sted, at det er i ark: Deling af data

Denne databearbejdning skal bare ske, når hele målingen er slut.

Her er hele programmet:

Public RunWhen As Double
Public cRunIntervalSeconds  ' one minutes
Public Const cRunWhat = "TheSub"
Public I As Long


Public SlutTid As Date ' NY linie


Sub Pico()
Dim AntalGange As Integer ' NY linie
AntalGange = 180
If I = 0 Then
cRunIntervalSeconds = 1
ElseIf I >= 1 And I < AntalGange Then ' Rettet
cRunIntervalSeconds = 1
Else
cRunIntervalSeconds = 1
End If
RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, _
    schedule:=True
  '----------------------------------------------
  If I > 0 Then
  SlutTid = Now() + (TimeSerial(0, 0, 1) * ((AntalGange - I) * cRunIntervalSeconds))
  Sheets("Ark1").Range("F1") = SlutTid - Now()  ' NY linie
  End If
  '----------------------------------------------
 

End Sub

Sub TheSub()
If I = 0 Then
Sheets("Ark1").Columns("A:A").ClearContents
End If
  I = I + 1
  If I > 180 Then
      Call StopTimer
      Call Flyt
      MsgBox "Kopiering slut & data overført"
      Exit Sub
  End If
Sheets("Ark1").Range("A" & I) = Sheets("Ark1").Range("D1") ' Navn på hovedark
  Call Pico
End Sub

Sub StopTimer()
I = 0
  On Error Resume Next
  Application.OnTime earliesttime:=RunWhen, _
      procedure:=cRunWhat, schedule:=False
End Sub
Public Sub Flyt()
' ret arknavnet til dit ark
If Sheets("Ark2").Range("A1") = "" Then
A = 1
ElseIf Sheets("Ark2").Range("B1") = "" Then
A = 2
Else
A = Sheets("Ark2").Range("A1").End(xlToRight).Offset(0, 1).Column
End If
Sheets("Ark2").Cells(1, A) = Now()
For pp = 2 To 181
Sheets("Ark2").Cells(pp, A) = Sheets("Ark1").Range("A" & pp - 1).Value
Next

'kopierer N1, N2, N3, P1, P2, P3 fra ark(Sekant)


X = 1
For pp = 185 To 200
Sheets("Ark2").Cells(pp, A) = Sheets("start").Range("C" & X).Value
X = X + 1
Next


End Sub
Sub FindNærmeste()
Dim F As Variant, N As Integer, H1 As Integer, I As Integer, H As Variant, T As Integer
On Error Resume Next
F = Range("C2:e70") ' ret til dit område incl. den tomme kolonne der skal skrives i

    For I = 1 To UBound(F)
    H1 = 0
    H = 100
      For N = 1 To UBound(F)
     
      If F(I, 1) <> "" And F(N, 2) <> "" Then
     
          If F(N, 2) > F(I, 1) And F(N, 2) - F(I, 1) < H Then
            H = F(N, 2) - F(I, 1)
            H1 = N
          End If
         
          If F(N, 2) < F(I, 1) And F(I, 1) - F(N, 2) < H Then
            H = F(I, 1) - F(N, 2)
            H1 = N
          End If
         
      End If
     
      Next
     
        F(I, 3) = F(H1, 2)
        F(H1, 2) = ""
       
        If I = 1 Then
            For T = 1 To UBound(F)
                If F(T, 2) < F(I, 3) Then
                    F(T, 2) = ""
                End If
            Next
      End If
    Next
   
Range("c2:e70") = F ' ret til dit område incl. den tomme kolonne der skal skrives i

Public RunWhen As Double
Public cRunIntervalSeconds  ' one minutes
Public Const cRunWhat = "TheSub"
Public I As Long


Public SlutTid As Date ' NY linie


Sub Pico()
Dim AntalGange As Integer ' NY linie
AntalGange = 180
If I = 0 Then
cRunIntervalSeconds = 1
ElseIf I >= 1 And I < AntalGange Then ' Rettet
cRunIntervalSeconds = 1
Else
cRunIntervalSeconds = 1
End If
RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, _
    schedule:=True
  '----------------------------------------------
  If I > 0 Then
  SlutTid = Now() + (TimeSerial(0, 0, 1) * ((AntalGange - I) * cRunIntervalSeconds))
  Sheets("Ark1").Range("F1") = SlutTid - Now()  ' NY linie
  End If
  '----------------------------------------------
 

End Sub

Sub TheSub()
If I = 0 Then
Sheets("Ark1").Columns("A:A").ClearContents
End If
  I = I + 1
  If I > 180 Then
      Call StopTimer
      Call Flyt
      Call FindNærmeste
      MsgBox "Kopiering slut & data overført"
      Exit Sub
  End If
Sheets("Ark1").Range("A" & I) = Sheets("Ark1").Range("D1") ' Navn på hovedark
  Call Pico
End Sub

Sub StopTimer()
I = 0
  On Error Resume Next
  Application.OnTime earliesttime:=RunWhen, _
      procedure:=cRunWhat, schedule:=False
End Sub
Public Sub Flyt()
' ret arknavnet til dit ark
If Sheets("Ark2").Range("A1") = "" Then
A = 1
ElseIf Sheets("Ark2").Range("B1") = "" Then
A = 2
Else
A = Sheets("Ark2").Range("A1").End(xlToRight).Offset(0, 1).Column
End If
Sheets("Ark2").Cells(1, A) = Now()
For pp = 2 To 181
Sheets("Ark2").Cells(pp, A) = Sheets("Ark1").Range("A" & pp - 1).Value
Next

'kopierer N1, N2, N3, P1, P2, P3 fra ark(Sekant)


X = 1
For pp = 185 To 200
Sheets("Ark2").Cells(pp, A) = Sheets("start").Range("C" & X).Value
X = X + 1
Next


End Sub

Sub FindNærmeste()
Dim F As Variant, N As Integer, H1 As Integer, I As Integer, H As Variant, T As Integer
On Error Resume Next
F = Sheets("Deling af data").Range("C2:E70")  ' ret til dit område incl. den tomme kolonne der skal skrives i

    For I = 1 To UBound(F)
    H1 = 0
    H = 100
      For N = 1 To UBound(F)
     
      If F(I, 1) <> "" And F(N, 2) <> "" Then
     
          If F(N, 2) > F(I, 1) And F(N, 2) - F(I, 1) < H Then
            H = F(N, 2) - F(I, 1)
            H1 = N
          End If
         
          If F(N, 2) < F(I, 1) And F(I, 1) - F(N, 2) < H Then
            H = F(I, 1) - F(N, 2)
            H1 = N
          End If
         
      End If
     
      Next
     
        F(I, 3) = F(H1, 2)
        F(H1, 2) = ""
       
        If I = 1 Then
            For T = 1 To UBound(F)
                If F(T, 2) < F(I, 3) Then
                    F(T, 2) = ""
                End If
            Next
      End If
    Next
   
Sheets("Deling af data").Range("C2:E70") = F ' ret til dit område incl. den tomme kolonne der skal skrives i

End Sub

det kører, men ikke helt rigtigt.

I kolonne c2-c70 er via kæde overføret fra kolonne a15-a83 og kolonne d2-d70 overføres fra a119 - a180. Når så macroen har kørt er disse koder væk til næste gang og de nye data overføres ikke.
Det er som om der slettes koder efter macroen har kørt, og der står ikke noget i d2-d70 men kun  i e2-70
Mine data kommer ind i 180 sec: f.eks.
22,62
22,62
22,62
22,62
22,62
22,62
22,62
22,6
22,6
22,6
22,6
22,6
22,62
22,64
23,16
23,98
24,64
25,16
25,62
25,62
25,98
26,32
26,6
26,82
27,04
27,22
27,38
27,52
27,64
27,76
27,86
27,96
28,04
28,1
28,18
28,24
28,3
28,34
28,4
28,4
28,44
28,48
28,52
28,56
28,6
28,62
28,66
28,68
28,72
28,74
28,76
28,8
28,82
28,84
28,86
28,9
28,9
28,92
28,96
28,96
28,96
28,98
29
29,02
29,04
29,06
29,08
29,1
29,12
29,12
29,14
29,16
29,18
29,18
29,2
29,22
29,24
29,24
29,1
28,48
28,48
27,82
27,32
26,96
26,54
26,16
25,78
25,48
25,22
25
24,82
24,66
24,5
24,42
24,32
24,24
24,14
24,06
23,98
23,9
23,84
23,84
23,78
23,72
23,68
23,64
23,6
23,6
23,58
23,56
23,54
23,52
23,5
23,48
23,44
23,4
23,38
23,36
23,4
24,12
24,82
25,42
25,42
25,88
26,3
26,64
26,94
27,2
27,42
27,6
27,78
27,94
28,08
28,2
28,3
28,4
28,48
28,56
28,64
28,7
28,76
28,82
28,86
28,86
28,92
28,96
29
29,06
29,08
29,12
29,14
29,18
29,2
29,24
29,26
29,28
29,3
29,34
29,36
29,38
29,4
29,42
29,44
29,44
29,46
29,48
29,48
29,5
29,52
29,54
29,56
29,58
29,58
29,6
29,62
29,62
29,64
29,66
29,68
29,68

Mine data skal så deles så der fra ca. a15 og 65 sec frem er et datasæt. De skal så sammelignes med data fra 115-180, og første tal i datarækken fra 115- skal være så tæt på a15 som muligt. Når de to kolonner derefter står for sig selv kan jeg regne videre på disse til næste ark via kæde.
Håber du forstår.

Håber du har tid til at se på det. Jeg bliver desværre nødt til at stoppe nu. Vender tilbage i morgen

ok der vil sige at du har formler i De 2 første kolonner

Jeg kan godt hoppe uden om første kolonne, men jeg kan ikke nulstille anden kolonne uden at fjerne formler.

Hvorfor overfører du ikke værdierne med makro, så var du fri for formler.  ?

Det ville være fint at få overført via en macro, som kører sammen med den anden macro, men jeg kan ikke fuínde ud af hvordan. Hvis det er lettere at hente tallene fra mine måledata er det lige så godt.Min første værdi i den første søjle er a15 og den første værdi er en af værdierne fra A114-a120, og det skal være den værdi, som er tættest på a15. Samtidig skal alle de efterfølgende værdier følge med.
Håber du kan komme videre ?
Tim

kan du ikke sende mig din demo mappe, jeg skal vide hvor data skal hentes og hvor de skal hen.

Det er arknavnene og cellerne, jeg skal bruge.

Skiv gerne en bemærkning i mappen om hvad du vil.

Jeg fandt ud af en enkelt løsning via nogle få HVIS sætninger (HVIS(OG($A$118<$C$2;$C$2<$A$119);A118;0)). Jeg laver nogle ny kolonner, hvor kolonnen bliver 0, hvis ikke de to tal ligger på hver side af udgangstallet. Jeg får derfor en kolonne med den rigtige startværdi, som jeg så kan sende videre i min beregning.

Under alle omstændigheder tak for forsøget, og jeg vender nok tilbage

Tim