ExcelMacro mit Sortier und Zählfunktion

Dieses Thema ExcelMacro mit Sortier und Zählfunktion im Forum "Microsoft Office Suite" wurde erstellt von tozupi, 2. Okt. 2006.

Thema: ExcelMacro mit Sortier und Zählfunktion Hallo, da ich ein Problem mit Excel habe, welches ich über ein Macro lösen muss, benötige mangels Wissen Eure...

  1. Hallo,

    da ich ein Problem mit Excel habe, welches ich über ein Macro lösen muss, benötige mangels Wissen Eure Hilfe. Ich bin da absolut planlos.

    Ich habe hier eine Tabelle die vereinfacht so aufgebaut ist:
    Datum------------Name-----Anzahl-----Summe
    01.01.2006------- a------- 1------- 10000
    03.01.2006------- a------- 2------- 3000
    05.01.2006------- c------- 3------- 10000
    08.01.2006------- c------- 2------- 1000
    05.02.2006------- d------- 3------- 15000
    08.02.2006------- a------- 5------- 28000
    09.03.2006------- b------- 8------- 30000

    Nur aus ca.1500 Sätzen mit vielmehr daten *Kopfqualm*

    Diese soll wie folgt ausgewertet werden:
    Pro Monat 1. Tabellenblatt mit folgender Auswertung:

    Name-------Summe (Anzahl)-------Summe (Summe)
    a-------------3------------------ 13000
    c-------------5------------------ 11000
    usw.
    Kann mir hier jemand zeigen wie das Macro auszusehen hat? Geht das überhaupt?

    Bin Für jede Hilfe echt dankbar
    Grüße
    Tozupi
     
  2. Hi

    ich würde gerne noch etwas wissen ... ist die Anzahl der Namen bestimmt? Also, gibt es abgesehen von a,b,c,d noch andere namen???
     
  3. Hi Billy,

    ja, es gibt noch mehr Namen in der Tabelle. So in Etwa 70-80 ....Leider :-(

    Das macht ja auch das manuelle bearbeiten so enorm Zeitraubend.

    Hast Du evtl einen Lösungsansatz?

    Wäre echt klasse.

    Ich danke Dir schon jetzt .

    Grüße
    Ralf
     
  4. Hallo tozupi,

    ein Lösung hab ich für dich.  ;D

    Das Makro in sollte in einem Modul in deiner Mappe liegen.
    Die Zeilen und Spalten-Angaben müßtest Du noch anpassen.
    (siehe im Kopf des Makros A N P A S S E N ).

    Gruß Matjes :)
    Code:
    Option Explicit
    
    '<<< A N P A S S E N >>>
    'Blattbeschreibung
    'ZeilenNummern
    Private Const cQ_Z_UEBERSCHRIFT = 1
    Private Const cQ_Z_ERSTEWERTEZEILE = 2
    'Spaltennummern
    Private Const cQ_SP_DATUM = 1
    Private Const cQ_SP_NAME = 2
    Private Const cQ_SP_ANZAHL = 3
    Private Const cQ_SP_SUMME = 4
    '<<< A N P A S S E N   E N D E >>>
    
    'Blattbeschreibung Auswertungsdatei
    Private Const cZ_BLTNAME_GESAMT = Gesamtauswertung
    Private Const cZ_Z_UEBERSCHRIFT = 1
    Private Const cZ_Z_ERSTEWERTEZEILE = 2
    Private Const cZ_SP_DATUM = 1
    Private Const cZ_SP_JAHRMONAT = 2
    Private Const cZ_SP_NAME = 3
    Private Const cZ_SP_ANZAHL = 4
    Private Const cZ_SP_SUMME = 5
    
    Sub AuswertungMonatNameSummeAnzahlSummeSumme()
    '*** Auswertung des aktiven Blattes nach
    '*** Monat,Name, Summe Anzahl, Summe Summe
    '***
    '*** Die Auswertung wird in eine neue Datei geschrieben
    '*** Pro Monat wird ein Blatt angelegt
    '*** Die Auswertung wird im Pfad der aktiven Mappe abgelegt
    '*** Name: Dateiname_Auswertungyyyymmddhhnnss.xls
    
      Dim wb As Workbook, ws As Worksheet, wbz As Workbook, wsz As Worksheet
      Dim x As Long
      
     ->aktive Mappe, aktives Blatt setzen
      Set wb = ActiveWorkbook
      Set ws = ActiveSheet
      
     ->Auswertedatei anlegen
      Set wbz = Workbooks.Add
     ->überflüssige Blätter löschen
      Application.DisplayAlerts = False
      For x = wbz.Worksheets.Count To 2 Step -1: wbz.Worksheets(x).Delete: Next
      Application.DisplayAlerts = True
      Set wsz = wbz.Worksheets(1)
      wsz.Name = cZ_BLTNAME_GESAMT
      wbz.SaveAs FileName:=wb.Path & Application.PathSeparator & _
                          Left(wb.Name, Len(wb.Name) - 4) & _
                           _Auswertung & Format(Now(), yyyymmddhhnnss) & .xls
      
     ->auszuwertende Daten auf cZIEL_BLTNAME_GESAMT übertragen
      Call AuszuwertendeDatenAufZielblattUebertragen(ws, wsz)
     ->auszuwertende Daten verdichten
      If Not AuszuwertendeDatenVerdichten(wsz) Then GoTo AUFRAEUMEN
     ->Monatsblätter erzeugen
      Call MonatsblaetterErzeugen(wbz, wsz)
      
     ->Gesamtauswertung löschen
      If wbz.Worksheets.Count > 1 Then
        Application.DisplayAlerts = False
        wbz.Worksheets(cZ_BLTNAME_GESAMT).Delete
        Application.DisplayAlerts = True
      End If
      wbz.Save->Zieldatei speichern
      
    AUFRAEUMEN:
      Set wb = Nothing: Set ws = Nothing: Set wbz = Nothing: Set wsz = Nothing
    End Sub
    
    '******************************************************************************
    Private Function AuszuwertendeDatenAufZielblattUebertragen(ws As Worksheet, _
                                                               wsz As Worksheet)
    
      Dim l_letzteZeileQ As Long, x As Long
      
     ->Splaten formatieren, Überschriften übertragen
      wsz.Columns(cQ_SP_DATUM).NumberFormat = yyyy-mm-dd
      With wsz.Cells(cZ_Z_UEBERSCHRIFT, cZ_SP_DATUM)
        .NumberFormat = @: .Font.Bold = True
        .Value = ws.Cells(cQ_Z_UEBERSCHRIFT, cQ_SP_DATUM).Value
      End With
      
      wsz.Columns(cQ_SP_DATUM).NumberFormat = @
      With wsz.Cells(cZ_Z_UEBERSCHRIFT, cZ_SP_NAME)
        .NumberFormat = @: .Font.Bold = True
        .Value = ws.Cells(cQ_Z_UEBERSCHRIFT, cQ_SP_NAME).Value
      End With
      wsz.Columns(cQ_SP_DATUM).NumberFormat = @
      
     ->eigene Spalte für Jahr/Monat
      With wsz.Cells(cZ_Z_UEBERSCHRIFT, cZ_SP_JAHRMONAT)
        .NumberFormat = @: .Font.Bold = True
        .Value = Jahr/Monat
      End With
      wsz.Columns(cZ_SP_JAHRMONAT).NumberFormat = @
      
      With wsz.Cells(cZ_Z_UEBERSCHRIFT, cZ_SP_ANZAHL)
        .NumberFormat = @: .Font.Bold = True
        .Value = ws.Cells(cQ_Z_UEBERSCHRIFT, cQ_SP_ANZAHL).Value
      End With
      
      With wsz.Cells(cZ_Z_UEBERSCHRIFT, cZ_SP_SUMME)
        .NumberFormat = @: .Font.Bold = True
        .Value = ws.Cells(cQ_Z_UEBERSCHRIFT, cQ_SP_SUMME).Value
      End With
    
     ->letzte Zeile aus Quellblatt feststellen
      l_letzteZeileQ = ws.Cells(ws.Rows.Count, cZ_SP_DATUM).End(xlUp).Row
    
     ->Werte vom Quellblatt auf Zielblatt kopieren
      ws.Range(ws.Cells(cQ_Z_ERSTEWERTEZEILE, cQ_SP_DATUM), _
               ws.Cells(l_letzteZeileQ, cQ_SP_DATUM)).Copy
      wsz.Cells(cZ_Z_ERSTEWERTEZEILE, cZ_SP_DATUM).Select
      Selection.PasteSpecial _
        Paste:=xlValues, _
        Operation:=xlNone, _
        SkipBlanks:=False, _
        Transpose:=False
      wsz.Columns(cQ_SP_DATUM).NumberFormat = yyyy-mm-dd
      wsz.Cells(cZ_Z_UEBERSCHRIFT, cZ_SP_DATUM).NumberFormat = @
      
      ws.Range(ws.Cells(cQ_Z_ERSTEWERTEZEILE, cQ_SP_NAME), _
               ws.Cells(l_letzteZeileQ, cQ_SP_NAME)).Copy
      wsz.Cells(cZ_Z_ERSTEWERTEZEILE, cZ_SP_NAME).Select
      wsz.Paste
      
      ws.Range(ws.Cells(cQ_Z_ERSTEWERTEZEILE, cQ_SP_ANZAHL), _
               ws.Cells(l_letzteZeileQ, cQ_SP_ANZAHL)).Copy
      wsz.Cells(cZ_Z_ERSTEWERTEZEILE, cZ_SP_ANZAHL).Select
      wsz.Paste
      
      ws.Range(ws.Cells(cQ_Z_ERSTEWERTEZEILE, cQ_SP_SUMME), _
               ws.Cells(l_letzteZeileQ, cQ_SP_SUMME)).Copy
      wsz.Cells(cZ_Z_ERSTEWERTEZEILE, cZ_SP_SUMME).Select
      wsz.Paste
    
     ->Grid setzen
      With wsz.UsedRange
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        For x = 7 To 12
          With .Borders(x):
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
          End With
        Next
      End With
      
      wsz.Cells(1, 1).Select
    End Function
    
    '******************************************************************************
    Private Function AuszuwertendeDatenVerdichten(wsz As Worksheet) As Boolean
    
      Dim lRows As Long, x As Long
      Dim dDate1 As Date, dDate2 As Date
      
     ->letzte Zeile aus Quellblatt feststellen
      lRows = wsz.Cells(wsz.Rows.Count, cZ_SP_DATUM).End(xlUp).Row
      
     ->Spalte Datum prüfen
      For x = cZ_Z_ERSTEWERTEZEILE To lRows
        If Not IsDate(wsz.Cells(x, cZ_SP_DATUM).Value) Then
          MsgBox _
            Datum in Zeile  & x &  ist ungültig. & vbLf & _
            Bitte korrigieren und Makro erneut starten.
          GoTo AUFRAEUMEN
        End If
      Next
      
     ->Nach Name, Datum sortieren
      wsz.Range(wsz.Cells(cZ_Z_ERSTEWERTEZEILE, 1), _
                wsz.Cells(lRows, wsz.UsedRange.Columns.Count)).Sort _
          Key1:=wsz.Cells(cZ_Z_ERSTEWERTEZEILE, cZ_SP_NAME), Order1:=xlAscending, _
          Key2:=wsz.Cells(cZ_Z_ERSTEWERTEZEILE, cZ_SP_DATUM), Order2:=xlAscending, _
          Header:=xlNo
    
      For x = lRows To cZ_Z_ERSTEWERTEZEILE + 1 Step -1
       ->Zeile und vorhergehende Zeile
       ->gleicher Name ?
        If wsz.Cells(x, cZ_SP_NAME).Value = wsz.Cells(x - 1, cZ_SP_NAME).Value Then
         ->Pruefen ob gleicher Monat
          dDate1 = wsz.Cells(x, cZ_SP_DATUM).Value
          dDate2 = wsz.Cells(x - 1, cZ_SP_DATUM).Value
          If (Year(dDate1) = Year(dDate2)) And _
             (Month(dDate1) = Month(dDate2)) Then
           ->Monat/Jahr gleich -> ANZAHL, SUMME verdichten
            wsz.Cells(x - 1, cZ_SP_ANZAHL).Value = _
            wsz.Cells(x - 1, cZ_SP_ANZAHL).Value + wsz.Cells(x, cZ_SP_ANZAHL).Value
            wsz.Cells(x - 1, cZ_SP_SUMME).Value = _
            wsz.Cells(x - 1, cZ_SP_SUMME).Value + wsz.Cells(x, cZ_SP_SUMME).Value
            wsz.Rows(x).Delete
          End If
        End If
      Next
      
     ->letzte Zeile aus Quellblatt feststellen
      lRows = wsz.Cells(wsz.Rows.Count, cZ_SP_DATUM).End(xlUp).Row
     ->Spalte Jahr/Monat ausfüllen, Spalte Datum auf den 1. des Monats setzen
      For x = cZ_Z_ERSTEWERTEZEILE To lRows
        dDate1 = wsz.Cells(x, cZ_SP_DATUM).Value
        wsz.Cells(x, cZ_SP_JAHRMONAT).Value = Year(dDate1) &   & Format(dDate1, mmm)
        dDate1 = 1. & Month(dDate1) & . & Year(dDate1)
        wsz.Cells(x, cZ_SP_DATUM).Value = dDate1
      Next
     ->Nach Datum,Name sortieren
      wsz.Range(wsz.Cells(cZ_Z_ERSTEWERTEZEILE, 1), _
                wsz.Cells(lRows, wsz.UsedRange.Columns.Count)).Sort _
          Key1:=wsz.Cells(cZ_Z_ERSTEWERTEZEILE, cZ_SP_DATUM), Order1:=xlAscending, _
          Key2:=wsz.Cells(cZ_Z_ERSTEWERTEZEILE, cZ_SP_NAME), Order2:=xlAscending, _
          Header:=xlNo
      
      AuszuwertendeDatenVerdichten = True
    AUFRAEUMEN:
    End Function
    
    '******************************************************************************
    Private Function MonatsblaetterErzeugen(wbz As Workbook, wsz As Worksheet)
      Dim ws As Worksheet, Zelle As Range
      Dim sJahrMonat As String, lRowEnd As Long, lRowAnf As Long, x As Long
      
      Do
       ->letzte Zeile aus Quellblatt feststellen
        lRowEnd = wsz.Cells(wsz.Rows.Count, cZ_SP_DATUM).End(xlUp).Row
       ->alles abgearbeitet ?
        If lRowEnd <= cZ_Z_ERSTEWERTEZEILE Then Exit Do
        
        sJahrMonat = wsz.Cells(lRowEnd, cZ_SP_JAHRMONAT).Value
       ->Anfang des Monats suchen
        If lRowEnd = cZ_Z_ERSTEWERTEZEILE Then
          lRowAnf = lRowEnd->nur eine Zeile übrig
        Else
          Set Zelle = wsz.Range( _
                        wsz.Cells(cZ_Z_ERSTEWERTEZEILE, cZ_SP_JAHRMONAT), _
                        wsz.Cells(lRowEnd, cZ_SP_JAHRMONAT)).Find( _
                        What:=sJahrMonat, _
                        After:=wsz.Cells(lRowEnd, cZ_SP_JAHRMONAT), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext)
                                
          lRowAnf = Zelle.Row
        End If
        
       ->Gesamtauswertung-Blatt an den Anfang der Mappe kopieren
        wsz.Copy Before:=wbz.Worksheets(1)
        Set ws = ActiveSheet
       ->Blattnamen setzen Jahr/Monat
        ws.Name = sJahrMonat
       ->Zeilen, die nicht zu diesem Monat gehören, löschen
        If lRowAnf > cZ_Z_ERSTEWERTEZEILE Then
          ws.Rows(cZ_Z_ERSTEWERTEZEILE & : & (lRowAnf - 1)).Delete
        End If
       ->Spalte JahrMonat und Spalte Datum löschen
        ws.Columns(cZ_SP_JAHRMONAT).Delete
        ws.Columns(cZ_SP_DATUM).Delete
        
       ->in der Gesamtauswetung Monatszeilen löschen (abgearbeitet)
        wsz.Rows(lRowAnf & : & lRowEnd).Delete
      
      Loop
    
    AUFRAEUMEN:
      Set ws = Nothing: Set Zelle = Nothing
    End Function
     
  5. Hallo Zusammen,

    hätte man das ganze nicht auch (vielleicht einfacher) mit einer Pivot-Tabelle lösen können?

    Grüße
    falcon30
     
  6. Hi Matjes,

    ersteinmal DANKE für die arbeit die Du Dir gemacht hast. *WOW* :1

    Ein erstes schauen und ich versteh erstmal nur Bahnhof (Ist halt nicht mein Thema). Ich werde mir Dein Macro heute,bzw. morgen genauer anschauen um es dann an meine Gegebenheiten anzupassen. Ich hoffe ich werde schlau daraus, habe aber die Hoffnung mit Deinen Kommentaren das richtige zu tun.

    Wie lange hast Du denn dafür gebraucht? Ich hoffe nicht Stunden ;-)
    Die werde ich letztendlich dazu benötigen alles so zum laufen zu bringen wie ich es benötige.

    Nochmal herzlichen Dank. Ich lasse es Dich wissen, ob ich es dann geschafft habe.

    Grüße
    Ralf
     
Die Seite wird geladen...

ExcelMacro mit Sortier und Zählfunktion - Ähnliche Themen

Forum Datum
Sortiertes Ausdrucken über Windows-Explorer (-> pdf) Windows 7 Forum 9. Dez. 2013
Sortierung im Windows Explorer Windows XP Forum 28. Mai 2013
Dateien sortieren Windows XP Forum 18. März 2013
Dateien sortieren ? Windows 7 Forum 27. Okt. 2011
Datein in einem Ordner selber sortieren Windows XP Forum 20. Jan. 2011