Flytning af kolonne

"Gammel" macro og se evt gammelt spørgsmål http://exp.dk/spm/642054


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 = 70
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 > 70 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 70
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 = 73 To 83
Sheets("Ark2").Cells(pp, A) = Sheets("start").Range("C" & X).Value
X = X + 1
Next


End Sub

rettet i denne

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()

Sheets("Ark3").Cells(1, "B") = Sheets("Ark2").Cells(1, A) ' Dato sidste kolonne
Sheets("Ark3").Cells(1, "A") = Sheets("Ark2").Cells(1, A - 1) ' Dato næst sidste kolonne

For pp = 2 To 70
Sheets("Ark2").Cells(pp, A) = Sheets("Ark1").Range("A" & pp - 1).Value

    Sheets("Ark3").Cells(pp, "A") = Sheets("Ark2").Cells(pp, A - 1).Value  ' Næst sidste kolonne
    Sheets("Ark3").Cells(pp, "B") = Sheets("Ark2").Cells(pp, A) ' Sidste kolonne
   
Next
'kopierer N1, N2, N3, P1, P2, P3 fra ark(Sekant)
X = 1
For pp = 73 To 83
Sheets("Ark2").Cells(pp, A) = Sheets("start").Range("C" & X).Value
X = X + 1
Next
End Sub

Ved første forsøg så det sku ud til at virke.....................

Jeg tester videre og jeg melder tilbage

Tim

Alt virker. Det er sku utrolig så let du kan klare mine problemer.
Tak for hjælpen.
Send et svar, så du kan få point

mvh
Tim

et svar ;-))