Jeg nu : Ark 1: data hentes ind i D1 og måles løbende i kolonne A når macroen startes. Når en ny måling begynder overføres data til ark 2, hvor resultatet i kolonne A fra ark 1 gemmes sammen med et felt øverst med dato og tidspunkt. Tredje ark hedder ”Sekant” og i det ark foretages mine beregninger. Resultaterne af beregningerne kommer i felt: N1, N2, N3, P1, P2, P3. Disse resultater skulle gerne gemmes sammen måledata fra ark 1 og dato i ark 2. Yderligere ville jeg gerne, når jeg skal lave en ny måling, have 5 felter, hvor jeg kan skrive relevante data ind for denne måling før macroen starter: 1) navn 2) fødselsdag 3) sensor 4) sted 5) kommentarer Disse data skulle så samtidig gemmes sammen med de andre data i ark 2, når målingen er udført.
For at gøre beregningen brugervenlig ville jeg gerne kunne starte det hele op i Powerpoint: ”billede 1”: Indføre data (punkt 1-5 se ovenfor). ”billede 2”: starte min macro ”billede 3”: mulighed for at se, at målingen er i gang. Det ville være godt at der var en graf, hvor måleresultaterne fra ark 1 kolonne A ses i forhold til tiden. ”billede 4”: Se resultaterne af målingen (N1, N2, N3, P1, P2, P3) og samtidig se grafen fra billede 3 samt en anden graf fra sekant arket (kolonne T).
1. den er nem nok, men powerpoint, har jeg aldrig programmeret i,ej hellerbrugt den ret meget.
Ved 1. skriver du i 5 ledige celler på ark 1, så der de nemme at overføre.
Resten vil jeg helst ikke røre ved, da jeg er bange for at det bliver en langsommelig, programmering og nok ikke optimal, så jeg ser helst at en anden tager over.
Her er koden rettet så den tager felt: N1, N2, N3, P1, P2, P3 fra arket ”Sekant”
Det næste er, har du 5 ledige celler i ark1, til: 1) navn 2) fødselsdag 3) sensor 4) sted 5) kommentarer
Så vil jeg godt vide det, helst i samme kolonne og i rækkefølge. ?
Jeg vil også godt vide hvilken rækkefølge de skal skrives i ark2. ?
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 26 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 = 27 To 29 Sheets("Ark2").Cells(pp, A) = Sheets("Sekant").Range("N" & X).Value Sheets("Ark2").Cells(pp + 3, A) = Sheets("Sekant").Range("P" & X).Value X = X + 1 Next End Sub
I ark 1 er der kun brugt kolonne A og D1. De ekstra felter må gerne gemmes i samme kolonne som værdierne fra målingen, dvs f.eks fra felt 30 og nedad. Det er muligt, at jeg genre have flere end 5 felter, så hvis programmet bliver sat til at gemme fra f.eks. ark 1 kolonne C1 til C10 under de andre overførte værdier, vil det være fint.
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 26 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 = 27 To 29 Sheets("Ark2").Cells(pp, A) = Sheets("Sekant").Range("N" & X).Value Sheets("Ark2").Cells(pp + 3, A) = Sheets("Sekant").Range("P" & X).Value X = X + 1 Next
'kopierer fra ark1 C1 til C10 For pp = 33 To 43 Sheets("Ark2").Cells(pp, A) = Sheets("Ark1").Range("C" & pp - 32).Value Next End Sub
Lige et lille spørgsmål før du får dine velfortjente point. Kan man lægge et felt/knap ind på skærmen eller ved ikonerne, hvorfra man kan starte /slukke pico, eller skal man altid via "alt-f8" ?
Find formularer, vælg knap, nu bliver muse iconet til et +, træk en firkant på arket, og du har knappen, den spørger nu om makro, vælg Pico, ret knappen til med tekst og placering , så er den klar
Jeg er så glad for at komme videre med mit arbejde, og du har været til stor hjælp. Nu da jeg har givet dig godt med point, kan det jo være at du vil hjælpe mig videre, når jeg løber ind i andre problemer!!
Kna du hjælpe en gang til - opretter gerne et nyt spøgsmål?
Jeg ville gerne ændre lidt på målingen, idet jeg gerne vil måle den første værdi efter 3 sekunder og derefter 10 værdier med 1 sekund imellem for så at slutte af med 22 værdier, som måles med 5 sekunder imellem ?
Der måles i D1 og værdierne skrives i A. Jeg vil gerne have at første måling kommer 3 sekunder efter at jeg har startet macroen, og derefter måles der i alt 10 gange (inkl. 1 målinger), sv.t. 10 sekunder. Herefter skal der måles hver 5 sekund så der afsluttes efter yderligere 22 værdier. Værdierne skrives bare videre ned ad kolonne A og slutter derfor senere.
Tim.
Public RunWhen As Double Public Const cRunIntervalSeconds = 5 ' two minutes Public Const cRunWhat = "TheSub" Public i As Long
Sub Pico() RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds) Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, _ schedule:=True End Sub
Sub TheSub() If i = 0 Then Sheets("Ark1").Columns("A:A").ClearContents End If i = i + 1 If i > 25 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 26 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 = 27 To 29 Sheets("Ark2").Cells(pp, A) = Sheets("Sekant").Range("N" & X).Value Sheets("Ark2").Cells(pp + 3, A) = Sheets("Sekant").Range("P" & X).Value X = X + 1 Next
'kopierer fra ark1 C1 til C10 For pp = 33 To 43 Sheets("Ark2").Cells(pp, A) = Sheets("Ark1").Range("C" & pp - 32).Value Next End Sub
Public RunWhen As Double Public cRunIntervalSeconds ' two minutes Public Const cRunWhat = "TheSub" Public i As Long
Sub Pico() If i = 0 Then cRunIntervalSeconds = 3 ElseIf i >= 1 And i < 10 Then cRunIntervalSeconds = 1 Else cRunIntervalSeconds = 5 End If RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds) Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, _ schedule:=True End Sub
Sub TheSub() If i = 0 Then Sheets("Ark1").Columns("A:A").ClearContents End If i = i + 1 If i > 32 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 33 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 = 34 To 36 Sheets("Ark2").Cells(pp, A) = Sheets("Sekant").Range("N" & X).Value Sheets("Ark2").Cells(pp + 3, A) = Sheets("Sekant").Range("P" & X).Value X = X + 1 Next
'kopierer fra ark1 C1 til C10 For pp = 40 To 50 Sheets("Ark2").Cells(pp, A) = Sheets("Ark1").Range("C" & pp - 39).Value Next End Sub
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.
