Sortierung anhand von 3 Kriterien

Bild

Betrifft: Sortierung anhand von 3 Kriterien von: Thomas K.
Geschrieben am: 10.02.2005 13:44:39

Hallo,

Großes Problem ???


Habe folgend Aufgabe :

Excel Tabelle mit fortlaufenden einträgen in der form:

Spalte A Datum in der form 01.01.05 Tag/Monat/Jahr
Spalte B Kostenstelle in der form einer Zahl
Spalte C Bemerkung in form von Text
Spalte D Betrag in der form €

Nun möchte ich das anhand vom Monat und Jahr und Kostenstelle der Betrag in eine andere Tabelle Erscheint .
Die Tabellen sollen jeweils eine Monatsnamen haben
In den Tabellen soll dann für jedes Jahr einen bereich geben, in dem dann die einzelnen Kostenstellen anhand ihrer Nummer zusammengerechnet werden sollen.
Also eine Sortierung anhand von 3 Kriterien.

Kann man das mit Excel Hinkriegen ????

Danke schon jetzt.


Mit freundlichen Grüßen Thomas.K

Bild


Betrifft: AW: Sortierung anhand von 3 Kriterien von: Galenzo
Geschrieben am: 10.02.2005 14:48:35

ja - am besten mit einer Pivottabelle


Bild


Betrifft: AW: Sortierung anhand von 3 Kriterien von: Josef Ehrensberger
Geschrieben am: 10.02.2005 15:11:31

Hallo Thomas!

Entweder Pivottabelle oder du versuchst mal diesen Code.


      
Option Explicit

Sub KostenstellenAufteilen()
Dim wks As Worksheet, liste As Worksheet
Dim lastRow As Long, lRow As Long
Dim firstY As Integer, icol As Integer, shtC As Integer
Dim n As Integer, m As Integer, i As Integer
Dim rng As Range


On Error GoTo ERRORHANDLER

With Application
.ScreenUpdating = 
False
.EnableEvents = 
False
.DisplayAlerts = 
False
.Calculation = xlCalculationManual
End With

'Tabelle mit der Liste
Set liste = Worksheets("Tabelle1")

shtC = ThisWorkbook.Sheets.Count

'länge der Liste ermitteln
lastRow = lastR(liste)

'kleinste Jahreszahl der Liste ermitteln
firstY = Year(Application.Min(liste.Range("A:A")))
        
   
For Each rng In liste.Range("A2:A" & lastRow)
   
         
'feststellen ob Tabellenblatt bereits existiert(Monat der Liste)
         If SheetExist(Format(rng, "MMMM")) Then
         
Set wks = Sheets(Format(rng, "MMMM"))
         
Else
         
Set wks = Worksheets.Add(after:=Sheets(Sheets.Count))
         wks.Name = Format(rng, 
"MMMM")
         
End If
      
      
'Ausgabespalte bestimmen
      icol = ((Year(rng) - firstY) * 5) + 1
      
      
'Ausgabezeile bestimmen
      lRow = lastR(wks, icol) + 1
      
         
'Überschrift erstellen
            If wks.Cells(1, icol) = "" Then
            wks.Cells(1, icol) = Year(rng)
            wks.Cells(1, icol + 1) = 
"Kostenstelle"
            wks.Range(wks.Cells(1, icol), wks.Cells(1, icol + 1)).Font.Bold = 
True
         
End If
      
      
'Daten übertragen
      wks.Range(wks.Cells(lRow, icol), wks.Cells(lRow, icol + 3)).Value = _
      liste.Range(liste.Cells(rng.Row, 1), liste.Cells(rng.Row, 4)).Value
      
      
'Summe einfügen
      wks.Cells(lRow + 1, icol + 3) = _
      Application.Sum(wks.Range(wks.Cells(2, icol + 3), wks.Cells(lRow, icol + 3)))
      
      
'Währungsformat
      wks.Cells(lRow + 1, icol + 3).NumberFormat = "$ #,##0.00"
   
   
Next


m = ThisWorkbook.Worksheets.Count

   
'Nicht benötigte Spalten entfernen
   For i = shtC + 1 To m
      
If Sheets(i).Cells(1, 1) = "" Then Sheets(i).Columns("A:E").Delete
   
Next

'Monatsblätter sortieren
For i = shtC + 1 To m
   
For n = i To m
       
If Month(DateValue("1/" & Sheets(n).Name & "/2000")) < _
               Month(DateValue(
"1/" & Sheets(i).Name & "/2000")) Then
               
           Sheets(n).Move Before:=Sheets(i)
       
       
End If
   
Next n
Next i

liste.Activate

ERRORHANDLER:

With Application
.ScreenUpdating = 
True
.EnableEvents = 
True
.DisplayAlerts = 
True
.Calculation = xlCalculationAutomatic
End With


End Sub


Private Function lastR(Optional WSheet As Excel.Worksheet, _
Optional ByVal Col As IntegerAs Long

If WSheet Is Nothing Then Set WSheet = ActiveSheet
If Col < 1 Or Col > 256 Then Col = 1

   
If WSheet.Cells(65536, Col) <> "" Then
      lastR = 65536
   
Else
      lastR = WSheet.Cells(65536, Col).End(xlUp).Row
   
End If

End Function



Private Function SheetExist(ByVal sheetName As StringOptional WbName As StringAs Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If WbName = "" Then WbName = ThisWorkbook.Name
For Each wks In Workbooks(WbName).Worksheets
If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = 
False
End Function 


     Code eingefügt mit Syntaxhighlighter 3.0



Gruß Sepp

P.S.: Rückmeldung nicht vergessen!


Bild


Betrifft: AW: Sortierung anhand von 3 Kriterien von: Thomas K.
Geschrieben am: 10.02.2005 15:45:35

Hallo ,

Dank an Galenzo und Josef Ehrensberger

Aber mit dem Code von Josef Ehrensberger kann ich LEIDER NICHTS anfangen da ich mit VBA keine Ahnung habe .Bitte um Hilfe.

Mit freundlichen Grüßen Thomas K.


Bild


Betrifft: AW: Sortierung anhand von 3 Kriterien von: Josef Ehrensberger
Geschrieben am: 10.02.2005 15:55:36

Hallo Thomas!

Drücke Alt+F11 um den VBA-Editor zu öffnen!

Gehe dort auf "Einfügen" > "Modul" und kopiere den kompletten Code
in das rechte Fenster.

Passe im Code "Tabelle1" an den Namen deiner Tabelle mit der Liste an!

Schliesse den VBE und gehe in Excel auf "Extras" > "Makro" > "Makros" und
klick auf Ausführen.

Hier nochmal der gesamte Code.


      
Option Explicit

Sub KostenstellenAufteilen()
Dim wks As Worksheet, liste As Worksheet
Dim lastRow As Long, lRow As Long
Dim firstY As Integer, icol As Integer, shtC As Integer
Dim n As Integer, m As Integer, i As Integer
Dim rng As Range


On Error GoTo ERRORHANDLER

With Application
.ScreenUpdating = 
False
.EnableEvents = 
False
.DisplayAlerts = 
False
.Calculation = xlCalculationManual
End With

'Tabelle mit der Liste
Set liste = Worksheets("Tabelle1")

shtC = ThisWorkbook.Sheets.Count

'länge der Liste ermitteln
lastRow = lastR(liste)

'kleinste Jahreszahl der Liste ermitteln
firstY = Year(Application.Min(liste.Range("A:A")))
        
   
For Each rng In liste.Range("A2:A" & lastRow)
   
         
'feststellen ob Tabellenblatt bereits existiert(Monat der Liste)
         If SheetExist(Format(rng, "MMMM")) Then
         
Set wks = Sheets(Format(rng, "MMMM"))
         
Else
         
Set wks = Worksheets.Add(after:=Sheets(Sheets.Count))
         wks.Name = Format(rng, 
"MMMM")
         
End If
      
      
'Ausgabespalte bestimmen
      icol = ((Year(rng) - firstY) * 5) + 1
      
      
'Ausgabezeile bestimmen
      lRow = lastR(wks, icol) + 1
      
         
'Überschrift erstellen
            If wks.Cells(1, icol) = "" Then
            wks.Cells(1, icol) = Year(rng)
            wks.Cells(1, icol + 1) = 
"Kostenstelle"
            wks.Range(wks.Cells(1, icol), wks.Cells(1, icol + 1)).Font.Bold = 
True
         
End If
      
      
'Daten übertragen
      wks.Range(wks.Cells(lRow, icol), wks.Cells(lRow, icol + 3)).Value = _
      liste.Range(liste.Cells(rng.Row, 1), liste.Cells(rng.Row, 4)).Value
      
      
'Summe einfügen
      wks.Cells(lRow + 1, icol + 3) = _
      Application.Sum(wks.Range(wks.Cells(2, icol + 3), wks.Cells(lRow, icol + 3)))
      
      
'Währungsformat
      wks.Cells(lRow + 1, icol + 3).NumberFormat = "$ #,##0.00"
   
   
Next


m = ThisWorkbook.Worksheets.Count

   
'Nicht benötigte Spalten entfernen
   For i = shtC + 1 To m
      
Do While Sheets(i).Cells(1, 1) = ""
         Sheets(i).Columns(
"A:E").Delete
      
Loop
   
Next

   
'Monatsblätter sortieren
   For i = shtC + 1 To m
      
For n = i To m
          
If Month(DateValue("1/" & Sheets(n).Name & "/2000")) < _
                  Month(DateValue(
"1/" & Sheets(i).Name & "/2000")) Then
                  
              Sheets(n).Move Before:=Sheets(i)
          
          
End If
      
Next n
   
Next i

liste.Activate

ERRORHANDLER:

With Application
.ScreenUpdating = 
True
.EnableEvents = 
True
.DisplayAlerts = 
True
.Calculation = xlCalculationAutomatic
End With


End Sub


Private Function lastR(Optional WSheet As Excel.Worksheet, _
Optional ByVal Col As IntegerAs Long

If WSheet Is Nothing Then Set WSheet = ActiveSheet
If Col < 1 Or Col > 256 Then Col = 1

   
If WSheet.Cells(65536, Col) <> "" Then
      lastR = 65536
   
Else
      lastR = WSheet.Cells(65536, Col).End(xlUp).Row
   
End If

End Function



Private Function SheetExist(ByVal sheetName As StringOptional WbName As StringAs Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If WbName = "" Then WbName = ThisWorkbook.Name
For Each wks In Workbooks(WbName).Worksheets
If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = 
False
End Function 


     Code eingefügt mit Syntaxhighlighter 3.0




Gruß Sepp

P.S.: Rückmeldung nicht vergessen!


Bild


Betrifft: kleine anpassung! von: Josef Ehrensberger
Geschrieben am: 10.02.2005 15:46:34

Hallo nochmal!

Ersetze die Codezeilen

   'Nicht benötigte Spalten entfernen
   For i = shtC + 1 To m
      If Sheets(i).Cells(1, 1) = "" Then Sheets(i).Columns("A:E").Delete
   Next

durch

   'Nicht benötigte Spalten entfernen
   For i = shtC + 1 To m
      Do While Sheets(i).Cells(1, 1) = ""
         Sheets(i).Columns("A:E").Delete
      Loop
   Next


Gruß Sepp

P.S.: Rückmeldung nicht vergessen!


Bild


Betrifft: AW: Sortierung anhand von 3 Kriterien von: Thomas K.
Geschrieben am: 10.02.2005 16:03:03

Hallo,
Danke Danke

Aber kann mir einer sagen was ich mit den Code machen soll.

Bin Leider mit VBA und Co noch total neu.

Will mich aber einarbeiten!!!!!!!!!!!!!!

MfG Thomas K.


Bild


Betrifft: AW: Sortierung anhand von 3 Kriterien von: Thomas K.
Geschrieben am: 10.02.2005 17:41:43

Hallo,

Als 1. Super Dank an alle die geholfen haben SUPER!!!!!!!!!!!!!!!!!!

Der Code von Josef Ehrensberger ist Spitze und soweit läuft er auch.

Nur noch zwei kleine Probleme habe ich noch.
1. Wenn das Makro Ausgeführt wir werden die Daten richtig sortiert aber es wird immer eine Lehre Tabelle am ende der Mappe angelegt ,diese wird aber nicht Benötigt.
2. Die Daten werden nach Monat und Jahr richtig Sortiert aber die Kostenstellen werden aber nicht sortiert .
Kann Mann das noch irgendwie einbauen ??

Danke schon für die Super Hilfe.

Mit freundlichen Grüßen Thomas K.


Bild


Betrifft: AW: Sortierung anhand von 3 Kriterien von: Josef Ehrensberger
Geschrieben am: 10.02.2005 18:25:33

Hallo Thomas!

Probier mal!



      
Option Explicit

Sub KostenstellenAufteilen()
Dim wks As Worksheet, liste As Worksheet
Dim lastRow As Long, lRow As Long, sRow As Long
Dim firstY As Integer, icol As Integer, shtC As Integer
Dim n As Integer, m As Integer, i As Integer
Dim rng As Range


On Error GoTo ERRORHANDLER

With Application
.ScreenUpdating = 
False
.EnableEvents = 
False
.DisplayAlerts = 
False
.Calculation = xlCalculationManual
End With

'Tabelle mit der Liste
Set liste = Worksheets("Tabelle1")

shtC = ThisWorkbook.Sheets.Count

'länge der Liste ermitteln
lastRow = lastR(liste)

'kleinste Jahreszahl der Liste ermitteln
firstY = Year(Application.Min(liste.Range("A:A")))
        
   
For Each rng In liste.Range("A2:A" & lastRow)
   
         
'feststellen ob Tabellenblatt bereits existiert(Monat der Liste)
         If SheetExist(Format(rng, "MMMM")) Then
         
Set wks = Sheets(Format(rng, "MMMM"))
         
Else
         
Set wks = Worksheets.Add(after:=Sheets(Sheets.Count))
         wks.Name = Format(rng, 
"MMMM")
         
End If
      
      
'Ausgabespalte bestimmen
      icol = ((Year(rng) - firstY) * 5) + 1
      
      
'Ausgabezeile bestimmen
      lRow = lastR(wks, icol) + 1
      
         
'Überschrift erstellen
            If wks.Cells(1, icol) = "" Then
            wks.Cells(1, icol) = Year(rng)
            wks.Cells(1, icol + 1) = 
"Kostenstelle"
            wks.Cells(1, icol + 2) = 
"Bemerkung"
            wks.Cells(1, icol + 3) = 
"Betrag"
            wks.Range(wks.Cells(1, icol), wks.Cells(1, icol + 3)).Font.Bold = 
True
         
End If
      
      
'Daten übertragen
      wks.Range(wks.Cells(lRow, icol), wks.Cells(lRow, icol + 3)).Value = _
      liste.Range(liste.Cells(rng.Row, 1), liste.Cells(rng.Row, 4)).Value
      
  
   
Next


m = ThisWorkbook.Worksheets.Count

   
'Nicht benötigte Spalten entfernen
   For i = shtC + 1 To m
      
Do While Sheets(i).Cells(1, 1) = ""
         Sheets(i).Columns(
"A:E").Delete
      
Loop
   
Next
   
   
'Nach Kostenstellen sortieren und Summen einfügen
   For i = shtC + 1 To m
   icol = 2
   lRow = 2
      
With Sheets(i)
      
         
Do While .Cells(1, icol) <> ""
         .Columns(icol).Sort Key1:=.Cells(1, icol), Order1:=xlAscending, Header:=xlGuess, _
           OrderCustom:=1, MatchCase:=
False, Orientation:=xlTopToBottom
         
         lastRow = lastR(Sheets(i), icol)
         sRow = 2
         
            
Do
            lRow = lRow + 1
            
               
If .Cells(lRow, icol) <> .Cells(lRow - 1, icol) Then
               .Range(.Cells(lRow, icol - 1), .Cells(lRow + 1, icol + 2)). _
                                          Insert Shift:=xlDown
               .Cells(lRow, icol + 2) = _
                           Application.Sum(.Range(.Cells(sRow, icol + 2), _
                              .Cells(lRow, icol + 2)))
                              
               .Cells(lRow, icol + 2).NumberFormat = 
"$ #,##0.00"
               .Cells(lRow, icol + 2).Font.Bold = 
True
               .Range(.Cells(lRow, icol - 1), .Cells(lRow, icol + 2)).Interior.ColorIndex = 19
               lRow = lRow + 2
               sRow = lRow - 1
               
End If
               
               
If .Cells(lRow, icol) = "" Then Exit Do
               
            
Loop
            
         icol = icol + 5
         lRow = 2
         
         
Loop
         
         .Columns.AutoFit
         
      
End With

   
Next
   

   
'Monatsblätter sortieren
   For i = shtC + 1 To m
      
For n = i To m
          
If Month(DateValue("1/" & Sheets(n).Name & "/2000")) < _
                  Month(DateValue(
"1/" & Sheets(i).Name & "/2000")) Then
                  
              Sheets(n).Move Before:=Sheets(i)
          
          
End If
      
Next n
   
Next i

liste.Activate

ERRORHANDLER:

With Application
.ScreenUpdating = 
True
.EnableEvents = 
True
.DisplayAlerts = 
True
.Calculation = xlCalculationAutomatic
End With


End Sub


Private Function lastR(Optional WSheet As Excel.Worksheet, _
Optional ByVal Col As IntegerAs Long

If WSheet Is Nothing Then Set WSheet = ActiveSheet
If Col < 1 Or Col > 256 Then Col = 1

   
If WSheet.Cells(65536, Col) <> "" Then
      lastR = 65536
   
Else
      lastR = WSheet.Cells(65536, Col).End(xlUp).Row
   
End If

End Function



Private Function SheetExist(ByVal sheetName As StringOptional WbName As StringAs Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If WbName = "" Then WbName = ThisWorkbook.Name
For Each wks In Workbooks(WbName).Worksheets
If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = 
False
End Function
Option Explicit

Sub KostenstellenAufteilen()
Dim wks As Worksheet, liste As Worksheet
Dim lastRow As Long, lRow As Long, sRow As Long
Dim firstY As Integer, icol As Integer, shtC As Integer
Dim n As Integer, m As Integer, i As Integer
Dim rng As Range


On Error GoTo ERRORHANDLER

With Application
.ScreenUpdating = 
False
.EnableEvents = 
False
.DisplayAlerts = 
False
.Calculation = xlCalculationManual
End With

'Tabelle mit der Liste
Set liste = Worksheets("Tabelle1")

shtC = ThisWorkbook.Sheets.Count

'länge der Liste ermitteln
lastRow = lastR(liste)

'kleinste Jahreszahl der Liste ermitteln
firstY = Year(Application.Min(liste.Range("A:A")))
        
   
For Each rng In liste.Range("A2:A" & lastRow)
   
         
'feststellen ob Tabellenblatt bereits existiert(Monat der Liste)
         If SheetExist(Format(rng, "MMMM")) Then
         
Set wks = Sheets(Format(rng, "MMMM"))
         
Else
         
Set wks = Worksheets.Add(after:=Sheets(Sheets.Count))
         wks.Name = Format(rng, 
"MMMM")
         
End If
      
      
'Ausgabespalte bestimmen
      icol = ((Year(rng) - firstY) * 5) + 1
      
      
'Ausgabezeile bestimmen
      lRow = lastR(wks, icol) + 1
      
         
'Überschrift erstellen
            If wks.Cells(1, icol) = "" Then
            wks.Cells(1, icol) = Year(rng)
            wks.Cells(1, icol + 1) = 
"Kostenstelle"
            wks.Cells(1, icol + 2) = 
"Bemerkung"
            wks.Cells(1, icol + 3) = 
"Betrag"
            wks.Range(wks.Cells(1, icol), wks.Cells(1, icol + 3)).Font.Bold = 
True
         
End If
      
      
'Daten übertragen
      wks.Range(wks.Cells(lRow, icol), wks.Cells(lRow, icol + 3)).Value = _
      liste.Range(liste.Cells(rng.Row, 1), liste.Cells(rng.Row, 4)).Value
      
  
   
Next


m = ThisWorkbook.Worksheets.Count

   
'Nicht benötigte Spalten entfernen
   For i = shtC + 1 To m
      
Do While Sheets(i).Cells(1, 1) = ""
         Sheets(i).Columns(
"A:E").Delete
      
Loop
   
Next
   
   
'Nach Kostenstellen sortieren und Summen einfügen
   For i = shtC + 1 To m
   icol = 2
   lRow = 2
      
With Sheets(i)
      
         
Do While .Cells(1, icol) <> ""
         .Columns(icol).Sort Key1:=.Cells(1, icol), Order1:=xlAscending, Header:=xlGuess, _
           OrderCustom:=1, MatchCase:=
False, Orientation:=xlTopToBottom
         
         lastRow = lastR(Sheets(i), icol)
         sRow = 2
         
            
Do
            lRow = lRow + 1
            
               
If .Cells(lRow, icol) <> .Cells(lRow - 1, icol) Then
               .Range(.Cells(lRow, icol - 1), .Cells(lRow + 1, icol + 2)). _
                                          Insert Shift:=xlDown
               .Cells(lRow, icol + 2) = _
                           Application.Sum(.Range(.Cells(sRow, icol + 2), _
                              .Cells(lRow, icol + 2)))
                              
               .Cells(lRow, icol + 2).NumberFormat = 
"$ #,##0.00"
               .Cells(lRow, icol + 2).Font.Bold = 
True
               .Range(.Cells(lRow, icol - 1), .Cells(lRow, icol + 2)).Interior.ColorIndex = 19
               lRow = lRow + 2
               sRow = lRow - 1
               
End If
               
               
If .Cells(lRow, icol) = "" Then Exit Do
               
            
Loop
            
         icol = icol + 5
         lRow = 2
         
         
Loop
         
         .Columns.AutoFit
         
      
End With

   
Next
   

   
'Monatsblätter sortieren
   For i = shtC + 1 To m
      
For n = i To m
          
If Month(DateValue("1/" & Sheets(n).Name & "/2000")) < _
                  Month(DateValue(
"1/" & Sheets(i).Name & "/2000")) Then
                  
              Sheets(n).Move Before:=Sheets(i)
          
          
End If
      
Next n
   
Next i

liste.Activate

ERRORHANDLER:

With Application
.ScreenUpdating = 
True
.EnableEvents = 
True
.DisplayAlerts = 
True
.Calculation = xlCalculationAutomatic
End With


End Sub


Private Function lastR(Optional WSheet As Excel.Worksheet, _
Optional ByVal Col As IntegerAs Long

If WSheet Is Nothing Then Set WSheet = ActiveSheet
If Col < 1 Or Col > 256 Then Col = 1

   
If WSheet.Cells(65536, Col) <> "" Then
      lastR = 65536
   
Else
      lastR = WSheet.Cells(65536, Col).End(xlUp).Row
   
End If

End Function



Private Function SheetExist(ByVal sheetName As StringOptional WbName As StringAs Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If WbName = "" Then WbName = ThisWorkbook.Name
For Each wks In Workbooks(WbName).Worksheets
If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = 
False
End Function 


     Code eingefügt mit Syntaxhighlighter 3.0




Gruß Sepp

P.S.: Rückmeldung nicht vergessen!


Bild


Betrifft: Sortierung anhand von 3 Kriterien von: Thomas K.
Geschrieben am: 11.02.2005 14:19:03

Hi :-)

Dank an Sepp

Der Code ist Super und macht genau das was ich will.

Das Forum ist echt Klasse weiter sooooooooooooooooooooo....


MfG Thomas K.


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Sortierung anhand von 3 Kriterien"