[Løst] Makro som lagrer et arbeidsark som ny fane i samme arbeidsbok

[Bigelk]

Hei.

 

Jeg har et program som lager en statistikk. Etter statistikken har blitt laget trenger jeg en knapp som lagrer den ferdige statistikken som en ny fane i samme arbeidsbok, men uten makroene. og navnet på den nye fanen skal være det samme som det som står i celle A2, det er da datoen. Hvis et ark med dette navnet allerede finnes trenger jeg en Ja/nei msgbox. hvis ja, slett det arket som har samme navn og opprett et nytt et. hvis nei. exit sub. Arkene trenger også å havne i riktig rekkefølge etter dato.

 

Noen som har noen forslag på hvordan det kan løses?

 

 

Hilsen

 

Torbjørn

Endret 6. desember 2011 av Bigelk

[Bigelk]

Hei.

 

Tror jeg snart har løst hvordan jeg skal opprette ett nytt ark.

On Error GoTo errorhandler

Application.ScreenUpdating = False
Sheets("Ark3").Select
range("a1:o48").Select
Selection.Copy
Sheets.Add before:=Sheets("uke1")
ActiveSheet.Paste
ActiveSheet.Name = range("a2")
range("a2").Select

errorhandler:
If Err.Number = 1004 Then
   yesno = MsgBox("Arket finnes allerede, vil du slette det gamle arket og opprette et nytt et. klikk ja. HVis ikke klikk Nei.", vbYesNo + vbCritical, "Caution")
       Select Case yesno
               Case vbYes


                   Application.DisplayAlerts = False
                       ActiveSheet.Delete
                   Application.DisplayAlerts = True
                   Sheets("ark3").Select
                   range("a1:o48").Select
                   Selection.Copy
                   Sheets("02.02.2011").Select
                   range("a1").Select
                   ActiveSheet.Paste
                   range("a2").Select


               Case vbNo
                   Application.DisplayAlerts = False
                       ActiveSheet.Delete
                   Application.DisplayAlerts = True

       End Select
End If

Sheets("ark3").Select
range("a2").Select

Application.ScreenUpdating = True

 

I case yes, i yesno case'n trenger jeg litt hjelp. Jeg ser for meg at det jeg trenger er en en kode som først sjekker hva det står i celle A2 i Ark3 så looper igjennom alle arkene etter Ark3 til den finner det arket som har det samme navnet som celle A2. så utføre resten av Koden.

 

Eller hvis noen har en helt annen måte og bygge opp koden på så tar jeg gjerne imot tips.

 

Håper forklaringene er gode nok, hvis ikke er det bare å si i fra.

 

 

 

Hilsen

 

Torbjørn

Endret 6. desember 2011 av Bigelk

[Bigelk]

Hei.

 

da er den nesten løst. men da dukket det selfølgelig opp et nytt problem. Problemet er at hele statistikken er full av formler, å når jeg bruker copy, paste så kopierer den ikke Verdien av cellen, men selve formelen. Så i de fleste cellene står det REF# i det lagrede arket

 

Løsningen så langt er

On Error GoTo errorhandler

x = cells(2, 1)
Application.ScreenUpdating = False
Sheets("plukk").Select
Range("a1:o48").Select
Selection.Copy
Sheets.Add before:=Sheets("uke1")
ActiveSheet.Paste
ActiveSheet.Name = Range("a2")
Range("a2").Select

errorhandler:
If Err.Number = 1004 Then
   yesno = MsgBox("Arket finnes allerede, vil du slette det gamle arket og opprette et nytt et. klikk ja. HVis ikke klikk Nei.", vbYesNo + vbCritical, "Caution")
       Select Case yesno
               Case vbYes
                   Application.DisplayAlerts = False
                       ActiveSheet.Delete
                   Application.DisplayAlerts = True
                   Sheets("plukk").Select
                   Range("a1:o48").Select
                   Selection.Copy
                   Sheets(x).Select
                   Range("a1").Select
                   ActiveSheet.Paste
                   Range("a2").Select
                   Sheets("plukk").Select
                   Range("a2").Select
               Case vbNo
                   Application.DisplayAlerts = False
                       ActiveSheet.Delete
                   Application.DisplayAlerts = True
      End Select

End If


On Error GoTo errorhandler2
sSummary.Move before:=Worksheets.Item(1)
sData.Move after:=sSummary
Dim n As Integer
Dim M As Integer
Dim dsEnd, lowest As Integer
Dim dCurrent() As String
Dim dOther() As String
Dim diff As Long
dsStart = 3
dsEnd = Worksheets.Count - 3

For M = dsStart To dsEnd
    For n = M To dsEnd
        If Worksheets(n).Name <> "Summary" And Worksheets(n).Name <> "Data" And Worksheets(M).Name <> "Summary" And Worksheets(M).Name <> "Data" Then
            dCurrent = Split(CStr(Worksheets(n).Name), ".")
            dOther = Split(CStr(Worksheets(M).Name), ".")
            diff = DateDiff("d", DateSerial(dCurrent(2), dCurrent(1), dCurrent(0)), DateSerial(dOther(2), dOther(1), dOther(0)))
            If diff > 0 Then
                Worksheets(n).Move before:=Worksheets(M)
            End If
        End If
    Next n
Next M

errorhandler2:
If Err.Number = 424 Then
On Error Resume Next
End If


Sheets("plukk").Select
Range("a2").Select

Application.ScreenUpdating = True

Det andre problemet er med selve koden. hvis jeg skal gjøre om en statistikk og lagre den på nytt. så går den ikke til errorhandler2. Jeg får i steden opp "run-time error 424. object recuired.

 

Noen som har noen forslag?

 

 

Mvh

 

Torbjørn

Endret 9. desember 2011 av Bigelk

[Bigelk]

Hei.

 

Da er den løst.

 

Løste kopierings problemet med og bruke Pastespecial. så den velger bare og lime inn verdien av formlene isteden for

selve formelen.

 

problem nr 2 løste jeg ved og bruke exit sub. fordi problemet oppsto i sorteringen av arket, men det finnes ikke noe ark som skal sorteres.

 

 

 

Application.ScreenUpdating = fale
On Error GoTo errorhandler

x = cells(2, 1)
Application.ScreenUpdating = False
Sheets("plukk").Select
Range("a1:o48").Select
Selection.Copy
Sheets.Add before:=Sheets("uke1")
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
ActiveSheet.Name = Range("a2")
Range("a2").Select

errorhandler:
If Err.Number = 1004 Then
   yesno = MsgBox("Arket finnes allerede, vil du slette det gamle arket og opprette et nytt et. klikk ja. HVis ikke klikk Nei.", vbYesNo + vbCritical, "Caution")
       Select Case yesno
               Case vbYes
                   Application.DisplayAlerts = False
                       ActiveSheet.Delete
                   Application.DisplayAlerts = True
                   Sheets("plukk").Select
                   Range("a1:o48").Select
                   Selection.Copy
                   Sheets(x).Select
                   Range("a1").Select
                       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                       :=False, Transpose:=False
                   Range("a2").Select
                   Sheets("plukk").Select
                   Range("a2").Select
                   Exit Sub
               Case vbNo
                   Application.DisplayAlerts = False
                       ActiveSheet.Delete
                   Application.DisplayAlerts = True
                   Sheets("plukk").Select
                   Range("a2").Select
                   Exit Sub                 
      End Select   
End If

On Error Resume Next
sSummary.Move before:=Worksheets.Item(1)
sData.Move after:=sSummary
Dim n As Integer
Dim M As Integer
Dim dsEnd, lowest As Integer
Dim dCurrent() As String
Dim dOther() As String
Dim diff As Long
dsStart = 4
dsEnd = Worksheets.Count - 3

For M = dsStart To dsEnd
    For n = M To dsEnd
        If Worksheets(n).Name <> "Summary" And Worksheets(n).Name <> "Data" And Worksheets(M).Name <> "Summary" And Worksheets(M).Name <> "Data" Then
            dCurrent = Split(CStr(Worksheets(n).Name), ".")
            dOther = Split(CStr(Worksheets(M).Name), ".")
            diff = DateDiff("d", DateSerial(dCurrent(2), dCurrent(1), dCurrent(0)), DateSerial(dOther(2), dOther(1), dOther(0)))
            If diff > 0 Then
                Worksheets(n).Move before:=Worksheets(M)
            End If
        End If
    Next n
Next M

Sheets("plukk").Select
Range("a2").Select

Application.ScreenUpdating = True

 

 

Hilsen

 

Torbjørn

Endret 19. desember 2011 av Bigelk