Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
728to732
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
728to732
728to732
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Tabelle nach Kriterium aufteilen
07.02.2006 10:21:12
Daniele
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.

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

Betreff
Datum
Anwender
Anzeige
AW: Tabelle nach Kriterium aufteilen
07.02.2006 11:00:14
Daniele
niemand eine idee?
gruß
AW: Tabelle nach Kriterium aufteilen
07.02.2006 11:58:58
Dr.
Wie soll das Kriterium denn identifiziert werden können?
AW: Tabelle nach Kriterium aufteilen
07.02.2006 12:52:47
Daniele
wie meinst du das?
also, es soll ja für jedes Kriterium eine extra Tabelle erstellt werden. Sprich ich habe eine tabbelle mit 100 zeilen, in Spalte A steht das Alter...jetzt möchte ich für jedes Alter eine extra tabelle!!!!
Sprich ich könnte den Autofilter setzen, und anfangen nach jedem vorhandenen Alter zu filtern, und die dadurch entstehenden Tabellen in ein extra Blatt kopieren...das hätte das gleiche Ergebnis, nur eben etwas komplizierter!
AW: Tabelle nach Kriterium aufteilen
07.02.2006 16:55:56
Josef
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!
'******************************

Anzeige
AW: Tabelle nach Kriterium aufteilen
08.02.2006 08:17:06
Daniele
Naja, irgendwie sitz ich gkaub aufm Schlauch....nachdem ich die Quelldatei angepasst habe passiert irgendwie gar nichts...
AW: Tabelle nach Kriterium aufteilen
08.02.2006 08:29:17
Daniele
Hallo!
Habe den Fehler gefunden....das Makro spricht nur Spate X an....das war von mir wahrscheinlich etwas dumm ausgedrückt, könntest du eine InputBox einbauen die anfangs fragt nach welcher spalte aufgeteilt werden soll?
Toll wäre es ausserdem noch wenn er das ganze Format mitnimmt...danke und Gruß
....wenn ich dich nicht hätte : )
bin schon selbst fleisig am lernen, aber dieser code is definitif zu hoch für mich
AW: Tabelle nach Kriterium aufteilen
08.02.2006 08:44:08
Daniele
hier ich habe es selbst mal versucht also den Teil mit der InputBox, aber wie zu erwarten klappts leider nicht.
Überall wo ich was verändert habe steht dahinter ein kommentar...'DANIELE

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 Spalte As String                                                      'DANIELE
Spalte = Val(InputBox("Spaltennummer:", "Tabelle aufteilen"))             'DANIELE
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, Spalte).End(xlUp).Row                      'DANIELE
lngAct = lngLast
varTemp = .Range("A2:IV" & lngLast)
Do While lngAct > 1
strFind = .Cells(2, Spalte)                                           'DANIELE
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, Spalte).End(xlUp).Row                    'DANIELE
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

Anzeige
AW: Tabelle nach Kriterium aufteilen
08.02.2006 12:07:34
Josef
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!
'******************************

Anzeige
AW: Tabelle nach Kriterium aufteilen
08.02.2006 14:54:08
Daniee
PERFEKT!!!
1000 DANK!
Viele Grüße
Daniel Poodratchi

44 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige