Flytte data automatisk til nyt ark

Nb jeg har også rettet i de andre, bla. fjernet select og copy, de er unødvendige

Public RunWhen As Double
Public Const cRunIntervalSeconds = 1  ' 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
Call Flyt
Columns("A:A").ClearContents
End If
  i = i + 1
  If i > 25 Then
      MsgBox "Kopiering slut"
      Call StopTimer
      Exit Sub
  End If
Range("A" & i) = Range("D1")
  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
For PP = 1 To 25
Sheets("Ark2").Cells(PP, A) = Range("A" & PP).Value
Next
 
End Sub

jeg ser på det om ca. ½ time

Tim

Har rettet lidt mere, bla. flyttes data når kopieringen er slut i stedet for ved næste start.

Har også henvist til dit hoved ark, for hvis du kikker på andre ark, samtidig med at din makro kører skriver den ikke det rigtige sted.

Du skal selv rette arknavnene til dem du bruger.

Du er vel klar over at du 'kun' kan have 256 data sæt på det ark du overflytter til, der er ikke flere end 256 kolonner

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
For PP = 1 To 25
Sheets("Ark2").Cells(PP, A) = Range("A" & PP).Value
Next
End Sub

Jeg prøver at køre nogle test.
Er der mulighed for at der øverst over de flyttede kolonner kan stå dato og tidspunkt automatisk ?
Tim

så er datotid med

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) = Range("A" & PP - 1).Value
Next
End Sub

Nå, vi skal vel også lige angive hovedsiden her.

Ark1 = hovedside
Ark2 = den side de kopieres over på

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
End Sub

jeg tror den er der.
Jeg tester lidt videre

Tim

Ja, så virker det også. Smukt.
Opretter du svar så du kan få point


Mange Tak

Tim

et svar. ;-))

tak for point

Se her: nu kommer du på endnu sværere opgave.
Håber du har lyst
Se: http://www.eksperten.dk/spm/462032

Tim

Kabbak!
Kan du lige hjælpe mig med en ændring i koden så jeg kan måle i milisekunder.
Macro måler i sekunder men jeg skal gerne måle hver ½ sekund.
Kan du klare det uden point eller skal jeg oprette til 15 point

Tim

Sub Pico()
If i = 0 Then
cRunIntervalSeconds = 3    '3 sekunder
ElseIf i >= 1 And i < 10 Then
cRunIntervalSeconds = 0.5  ' ½ sekund
Else
cRunIntervalSeconds = 5    '5 sekunder
End If
RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, _
    schedule:=True
End Sub

Macroen kører alt for hurtigt. De 10 målinger er klaret på under 1 sekund og ikke på 5 sekunder ?

Tim

så er der nok kun sleep tilbage, men så får du timeglas medens den kører



Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub Pico()

If i = 0 Then
Call Sleep(3000)
'cRunIntervalSeconds = 3
ElseIf i >= 1 And i < 10 Then
Call Sleep(500)
'cRunIntervalSeconds = 1
'
Else
'cRunIntervalSeconds = 5
Call Sleep(5000)
End If
RunWhen = Now ' + TimeSerial(0, 0, cRunIntervalSeconds)
Range("B" & i + 1) = RunWhen
Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, _
    schedule:=True

fjern lige

Range("B" & i + 1) = RunWhen

det var til test

hvis du kan bruge den, er den kortet af her.


Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)


Sub Pico()

If i = 0 Then
Call Sleep(3000)
TheSub
ElseIf i >= 1 And i < 10 Then
Call Sleep(500)
TheSub
Else
Call Sleep(5000)
TheSub
End If
End Sub

Ja, hvad skulle jeg gøre uden din hjælp!

Igen virker det, som jeg gerne ville have.

Skal vi oprette spørgsmål til point

Tim

Nej det er ok.

man kan også blande de  2 ting i koden.

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)



Sub Pico()
If i = 0 Then
cRunIntervalSeconds = 3 '3 sek.
ElseIf i >= 1 And i < 10 Then
Call Sleep(500)  ' ½ sek.
TheSub
Exit Sub
Else
cRunIntervalSeconds = 5  ' 5 sek.
End If
RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, _
    schedule:=True

End Sub

Den sidste fungerer også, men jeg ser nu et stort problem, idet disse macroer medfører at den måling, som kører i D1 (ark 1) bliver blokeret når macroen starter, så den ikke opdateres løbende. Det medfører at data som kommer til at stå i kolonne A er den samme værdi for målingerne og ikke en stigende måling.
Det hænger muligvis sammen med at der kommer timeglas frem, som så blokerer alle andre løbende beregninger/målinger?

Tim

Ok, så kan du ikke bruge sleep.

prøv med denne loop

Sub Pico()
If i = 0 Then
cRunIntervalSeconds = 3 '3 sek.
ElseIf i >= 1 And i < 10 Then
For XX = 1 To 3000  ' ca. ½ sek.på min pc. test så det passer
DoEvents
Next

TheSub
Exit Sub
Else
cRunIntervalSeconds = 5  ' 5 sek.
End If
RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, _
    schedule:=True

End Sub

perfekt
Det kører men jeg skulle bare ændre 3000 til 30 for at den skulle køre med ½ sec ?

Tak igen igen

Tim