Live-Forum - Die aktuellen Beiträge
Datum
Titel
20.04.2024 00:49:19
Excel Sheet in einen Excel Kalender einfügen
20.04.2024 00:08:11
In Ordner nur das Speichern von Dateien erlauben
19.04.2024 21:26:15
mehrfache Texte finden
19.04.2024 19:41:34
Bei VBA Ausführung Anzeige einfrieren
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
564to568
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
564to568
564to568
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Sortierung anhand von 3 Kriterien

Sortierung anhand von 3 Kriterien
10.02.2005 13:44:39
3
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

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Sortierung anhand von 3 Kriterien
3
ja - am besten mit einer Pivottabelle
AW: Sortierung anhand von 3 Kriterien
10.02.2005 15:11:31
3
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 Integer) As 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 String, Optional WbName As String) As 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 


Gruß Sepp
P.S.: Rückmeldung nicht vergessen!
Anzeige
AW: Sortierung anhand von 3 Kriterien
10.02.2005 15:45:35
3
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.
AW: Sortierung anhand von 3 Kriterien
10.02.2005 15:55:36
3
Hallo Thomas!
Drücke Alt+F11 um den VBA-Editor zu öffnen!
Gehe dort auf "Einfügen" &gt "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" &gt "Makro" &gt "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 Integer) As 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 String, Optional WbName As String) As 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 


Gruß Sepp
P.S.: Rückmeldung nicht vergessen!
Anzeige
kleine anpassung!
10.02.2005 15:46:34
Josef
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!
AW: Sortierung anhand von 3 Kriterien
10.02.2005 16:03:03
3
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.
Anzeige
AW: Sortierung anhand von 3 Kriterien
10.02.2005 17:41:43
3
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.
Anzeige
AW: Sortierung anhand von 3 Kriterien
10.02.2005 18:25:33
3
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 Integer) As 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 String, Optional WbName As String) As 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 Integer) As 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 String, Optional WbName As String) As 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 


Gruß Sepp
P.S.: Rückmeldung nicht vergessen!
Anzeige
Sortierung anhand von 3 Kriterien
3
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.

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige