Tabelle nach Kriterium aufteilen

Daniele · 2006-02-07T10:21:12+00:00

Hallo! Ich habe folgendes Problem: Ich habe eine riesige Tabelle. In Spalte x sind immerwieder kehrende bezeichnungen vorhanden. Insgesamt gibt es ca 10 verschiedene die dann aber mehrfach auftauchen in dieser Spalte. Ich bräuchte nun eine Funktion oder Makro welches mir diese Tabelle nach einer Spalte aufteilt und in ein neues Arbeitsblatt kopiert, exakt im selben Layout, am besten hat das Arbeitsblatt den Titel des Kriteriums. Also praktisch so als würde ich einen Autofilter setzen und nach jedem Kriterium filtern, kopieren und in ein neues Arbeitsblatt kopieren. Dem Arbeitsblatt würde ich dann den Namen des Kriterium geben. versteht ihr? Klar, so geht das auch, da dieser Prozess allerdings häufig vorgenommen wird, wäre ein Makro wirklich sehr hilfreich für mich. Hat jemand eine Idee? Vielen Dank schonmal im voraus! PS: Es wäre nett wenn anfangs eine Abfrage kommt wo man die Spalte angibt nach der aufgeteilt werden soll.

Hallo Daniele!
Probier mal!

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub KritToSheet()
Dim objShSource As Worksheet, objSh As Worksheet
Dim rng As Range, rngCopy As Range
Dim varTemp As Variant
Dim strFind As String, strFirst As String
Dim lngLast As Long, lngAct As Long

On Error GoTo ErrExit

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

Set objShSource = Sheets("Tabelle1") 'Quelltabelle - anpassen

With objShSource

  lngLast = .Cells(Rows.Count, 24).End(xlUp).Row
  lngAct = lngLast
  varTemp = .Range("A2:IV" & lngLast)

  Do While lngAct > 1

    strFind = .Cells(2, 24)

    Set rng = .Range("X2:X" & lngAct).Find(what:=strFind, lookat:=xlWhole)

    If Not rng Is Nothing Then
      strFirst = rng.Address
      Do
        If rngCopy Is Nothing Then
          Set rngCopy = .Rows(rng.Row)
        Else
          Set rngCopy = Union(rngCopy, .Rows(rng.Row))
        End If

        Set rng = .Range("X2:X" & lngAct).FindNext(rng)

      Loop While Not rng Is Nothing And strFirst <> rng.Address

    End If

    If Not rngCopy Is Nothing Then
      Set objSh = Worksheets.Add(after:=Sheets(Sheets.Count))
      On Error Resume Next
      objSh.Name = strFind
      If Err.Number <> 0 Then
        objSh.Name = strFind & Format(Now, "hhmmss")
        Err.Clear
      End If
      On Error GoTo ErrExit
      rngCopy.Copy objSh.Cells(2, 1)
      objShSource.Rows(1).Copy objSh.Rows(1)
      rngCopy.Delete
      Set rngCopy = Nothing
      Set objSh = Nothing
    End If

    lngAct = .Cells(Rows.Count, 24).End(xlUp).Row

  Loop

  .Range("A2:IV" & lngLast) = varTemp

End With

ErrExit:

Set objShSource = Nothing

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

End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Hallo Daniele!
Pobier mal!

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub KritToSheet()
Dim objShSource As Worksheet, objSh As Worksheet
Dim rng As Range, rngCopy As Range
Dim varTemp As Variant
Dim strFind As String, strFirst As String
Dim lngLast As Long, lngAct As Long
Dim rngCol As Range, intCol As Integer

On Error Resume Next
Set rngCol = Application.InputBox("Markieren Sie eine Zelle in der" & vbLf & _
  "gewünschten Spalte! (Kriterium)", "Tabelle aufteilen", ActiveCell.Address, Type:=8)

If rngCol Is Nothing Then Exit Sub

intCol = rngCol(1).Column

On Error GoTo ErrExit

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

rngCol.Parent.Copy After:=Sheets(Sheets.Count)

Set objShSource = Sheets(Sheets.Count)

With objShSource

  lngLast = .Cells(Rows.Count, intCol).End(xlUp).Row
  lngAct = lngLast

  Do While lngAct > 1

    strFind = .Cells(2, intCol)

    Set rngCol = .Range(.Cells(2, intCol), .Cells(lngAct, intCol))

    Set rng = rngCol.Find(what:=strFind, lookat:=xlWhole)

    If Not rng Is Nothing Then
      strFirst = rng.Address
      Do
        If rngCopy Is Nothing Then
          Set rngCopy = .Rows(rng.Row)
        Else
          Set rngCopy = Union(rngCopy, .Rows(rng.Row))
        End If

        Set rng = rngCol.FindNext(rng)

      Loop While Not rng Is Nothing And strFirst <> rng.Address

    End If

    If Not rngCopy Is Nothing Then
      Set objSh = Worksheets.Add(After:=Sheets(Sheets.Count))
      On Error Resume Next
      objSh.Name = strFind
      If Err.Number <> 0 Then
        objSh.Name = strFind & Format(Now, " hhmmss")
        Err.Clear
      End If
      On Error GoTo ErrExit
      rngCopy.Copy
      objSh.Cells(2, 1).PasteSpecial xlValues
      objSh.Cells(2, 1).PasteSpecial xlFormats
      Application.CutCopyMode = False
      objShSource.Rows(1).Copy objSh.Rows(1)
      rngCopy.Delete
      Set rngCopy = Nothing
      Set objSh = Nothing
    End If

    lngAct = .Cells(Rows.Count, intCol).End(xlUp).Row

  Loop

  .Delete

End With

ErrExit:

Set objShSource = Nothing
Set rngCol = Nothing

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

End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Forumthread: Tabelle nach Kriterium aufteilen

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial

Excel Tabelle nach Kriterien aufteilen

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)