[Løst] Excel 2007 VBA Lagre nytt ark. sortere etter dato

[Bigelk]

Hei.

 

Jeg har en makro som lagrer et nytt ark og sorterer det etter dato.

Men den forholder seg bare til en dato. f.eks 01.01.2013

 

Nå skal jeg lagre nye rapporter hvor datoen blir lagret som periode.

F.eks 01.01.2013-01.01.2013

01.01.2013-07.01.2013

01.01.2013-31.01.2013

 

Det jeg er ute etter er en makro som sorterer først etter den første datoen, så etter den andre datoen, altså differansen mellom de to datoene.

eks.

01.01.2013-07.01.2013 kommer før 01.01.2013-31.01.2013

mens

02.01.2013-02.01.2013 kommer etter begge disse.

 

Kodesnipp

 

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 - 1
 
    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

 

Er det mulig og modifesere denne koden så den fungerer på periode dato?

Eller må det lages noe nytt?

 

Bare si i fra hvis forklaringen ikke holder

 

 

Mvh

 

Torbjørn

[Bigelk]

Hei.

 

Har fått litt tid til å sette meg inn i koden så har kommet så langt at den klarer og sortere etter det første kriteriet

 

Option Explicit
Public n As Integer, M As Integer, dsEnd As Integer, DCurrent() As String, dOther() As String, diff As Long, _
dsStart As Integer, LstrNm As String, RStrNm As String, LRStrNmDiff As Long
Sub Sort_Sheet()

'    LstrNm = Left(Sheets(1).Name, 10)
'    RStrNm = Right(Sheets(1).Name, 10)
'    LRStrNmDiff = DateDiff("d", LstrNm, RStrNm)
 
    dsStart = 1
    dsEnd = Worksheets.Count - 1
   
    For M = dsStart To dsEnd
         For n = M To dsEnd
                DCurrent = Split(CStr(Left(Worksheets(n).Name, 10)), ".")
                dOther = Split(CStr(Left(Worksheets(M).Name, 10)), ".")
                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
        Next n
    Next M
   
End Sub
 

 

Hvis jeg forstår koden riktig så lager den et array som så sorteres.

Jeg tenker da at neste skritt blir å lage flere mindre Arrays ut i fra den første datoen i arknavnet.

altså alle ark som f.eks starter med 01.01.2013 blir et array som sorteres etter differansen.

 

Noen som vet hvordan man kan få til det?

Selvfølgelig bare å si i fra hvis jeg er helt på bærtur.

 

MVH

 

Torbjørn

[Harald Staff]

Det er krevende å rekonstruere oppsettet ditt for å prøvekjøre kode, så dette blir i teorien.

 

Hvis startdato er den samme så er diff 0. Da og bare da gjør du samme test med sluttdatoene, datoen etter bindestrek. Sannsynligvis er det bare å endre Left til Right hvis det ikke er fare for mellomrom etter sluttdato. Det ordner vi forresten med Trim. Jeg tror det blir

 

If diff < 0 Then
Worksheets(n).Move before:=Worksheets(M)

Elseif diff = 0 then

DCurrent = Split(CStr(Right(Trim(Worksheets(n).Name), 10)), ".")
dOther = Split(CStr(Right(Trim(Worksheets(M).Name), 10)), ".")
diff = DateDiff("d", DateSerial(DCurrent(2), DCurrent(1), DCurrent(0)), DateSerial(dOther(2), dOther(1), dOther(0)))
If diff < 0 then 'eller blir det > ? You fix

Worksheets(n).Move before:=Worksheets(M)

End if

End If

[Bigelk]

Du klarte det igjen Harald

Fungerer som en drøm.

 

å det ble forresten > som ble riktig.

Så tusen takk for hjelpen enda en gang

 

For M = dsStart To dsEnd
         For n = M To dsEnd
                DCurrent = Split(CStr(Left(Worksheets(n).Name, 10)), ".")
                dOther = Split(CStr(Left(Worksheets(M).Name, 10)), ".")
                diff = DateDiff("d", DateSerial(DCurrent(2), DCurrent(1), DCurrent(0)), DateSerial(dOther(2),
                dOther(1), dOther(0)))
                'snu < for å sortere minst til størst
                If diff < 0 Then
                    Worksheets(n).Move before:=Worksheets(M)
                ElseIf diff = 0 Then
                    DCurrent = Split(CStr(Right(Trim(Worksheets(n).Name), 10)), ".")
                    dOther = Split(CStr(Right(Trim(Worksheets(M).Name), 10)), ".")
                    diff = DateDiff("d", DateSerial(DCurrent(2), DCurrent(1), DCurrent(0)), DateSerial(dOther(2), dOther(1), dOther(0)))
                    If diff > 0 Then 'eller blir det > ? You fix
                        Worksheets(n).Move before:=Worksheets(M)
                    End If
                End If
        Next n
    Next M