Avatar billede timtoftgaard Praktikant
22. august 2005 - 14:38 Der er 11 kommentarer og
1 løsning

flytning af kolonne ud fra en værdi

Jeg har to kolonner med målinger.
I første kolonne skal der ikke ændres noget, men ud fra kolonne 2 skal der findes det tal, som er tættest på det første tal i kolonne 1, og derefter skal dette tal sættes forreste i en ny kolonne 3, og samtidig skal tallene fra kolonne 2 flyttes med over.
I      II
23,80    23,00
24,64    23,06
25,26    23,81
25,78    24,84
26,22    25,46
26,58    25,88
26,90    26,32

Resultatet skal se sådan ud
I                III
23,80            23,81
24,64            24,84
25,26            25,46   
25,78            25,88
26,22            26,32
26,58
26,90
Avatar billede kabbak Professor
22. august 2005 - 17:59 #1
er tallene i kolonne 1 altid stigende
Avatar billede kabbak Professor
22. august 2005 - 18:00 #2
er tallene i kolonne 1 altid stigende
og kolonne 2 også
Avatar billede timtoftgaard Praktikant
22. august 2005 - 18:04 #3
Ja
Avatar billede kabbak Professor
22. august 2005 - 18:12 #4
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
Avatar billede timtoftgaard Praktikant
22. august 2005 - 18:19 #5
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
Avatar billede timtoftgaard Praktikant
22. august 2005 - 18:31 #6
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
Avatar billede kabbak Professor
22. august 2005 - 19:15 #7
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
Avatar billede timtoftgaard Praktikant
22. august 2005 - 19:50 #8
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
Avatar billede kabbak Professor
22. august 2005 - 20:07 #9
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.  ?
Avatar billede timtoftgaard Praktikant
23. august 2005 - 14:56 #10
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
Avatar billede kabbak Professor
24. august 2005 - 16:59 #11
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.
Avatar billede timtoftgaard Praktikant
25. august 2005 - 13:47 #12
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
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester