41 Aufrufe
Gefragt in Windows 10 von satt Einsteiger_in (3 Punkte)
Hallo, wer kann helfen?

Ich habe eine Tabelle1 mit ca. 8000 Datensätzen und 13 Spalten die gefiltert bzw. sortiert werden soll: Kriterium ist die Spalte H worin sich wiederkehrende Zahlen befinden.

Die Ergebnisse der Tabelle1 sollen nun in der selben Arbeitsmappe in neue Tabellenblätter  jeweils mit der Überschrift aus Tabelle1  als Einzelposten abgelegt werden. Die Tabellenblätter sollen noch nach dem Suchkriterium der jeweiligen Zahl  Beispiel " 2345" umbenannt werden. Am Ende sollte ca. 30 neue Tabellenblätter mit Daten gefüllt sein,

Ich hoffe Ihr könnt helfen!

Vielen Dank!

Satt

3 Antworten

0 Punkte
Beantwortet von m-o Profi (16.8k Punkte)

Hallo Satt,

der folgende Code kopiert die Daten entsprechend den Werten der Spalte H in einzelne Arbeitsblätter. Sofern deine Tabelle1 anders heißt, musst du den Namen im Code entsprechend anpassen. Das Makro gehört in ein Modul deiner Arbeitsmappe. Es wird nicht geprüft, ob die einzelnen Tabellen in der Arbeitsmappe bereits existieren. Schau mal, ob das so für dich funktioniert:

Sub sort_copy()

Dim lngLetzte As Long
Dim lngZaehler As Long
Dim arrDaten As Variant
Dim arrH As Variant
Dim i As Long
Dim j As Long
Dim s As Long
Dim bExist As Boolean

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

With Worksheets("Tabelle1")
  'letzte beschriebene Zeile in Spalte H ermitteln
  lngLetzte = .Cells(Rows.Count, 8).End(xlUp).Row
  'Daten aus Blatt in Array einlesen
  arrDaten = .Range("A1:M" & lngLetzte)
End With
 
'Array für Zahlen redimensionieren
ReDim arrH(lngLetzte)
 
'nun die einzelnen Einträge in Spalte H ermitteln
'dafür den ersten Eintrag aus Zeile 2 vornehmen (in Zeile 1 befinden sich die Überschriften)
arrH(lngZaehler) = arrDaten(2, 8)
'nun das Feld ab Zeile 3 durchlaufen und die Zahlen mit den vorhandenen Einträgen der Einzelzahlen vergleichen
For i = 3 To UBound(arrDaten, 1)
  'Marker für gefundenen Eintrag zurück setzen
  bExist = False
  'Feld H durchlaufen und Einträge vergleichen
  For j = 1 To lngZaehler
    If arrDaten(i, 8) = arrH(j) Then
      'Marker auf wahr setzen, wenn Eintrag bereits vorhanden
      bExist = True
      'Schleife verlassen
      Exit For
    End If
  Next j
  'falls keine Übereinstimmung gefunden, dann Zahl in Array aufnehmen
  If bExist = False Then
    lngZaehler = lngZaehler + 1
    arrH(lngZaehler) = arrDaten(i, 8)
  End If
Next i

'nun Array H redimensionieren
ReDim Preserve arrH(lngZaehler)

'nun die Daten nach den einzelnen Einträgen aus Spalte H trennen
'arrH wird durchlaufen
For i = LBound(arrH) To UBound(arrH)
  'neues Arbeitsblatt am Ende einfügen
  ThisWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)
  With ActiveSheet
   'und benennen
   .Name = arrH(i)
   'Überschriften in das neue Tabellenblatt schreiebn
   For s = 1 To 13
      .Cells(1, s) = arrDaten(1, s)
   Next s
   'Zähler für Zeilen auf 1 festlegen
   lngZaehler = 1
   'nun alle Daten durchlaufen und übereinstimmende Datensätze in neues Blatt schreiben
   For j = 2 To UBound(arrDaten, 1)
     If arrH(i) = arrDaten(j, 8) Then
       'Zähler für Einfügezeile um 1 erhöhen
       lngZaehler = lngZaehler + 1
       'Datensätze in Blatt schreiben
       For s = 1 To 13
         .Cells(lngZaehler, s) = arrDaten(j, s)
       Next s
    End If
   Next j
   'Spaltenbreite automatisch anpassen
   .Columns("A:M").EntireColumn.AutoFit
  End With
Next i

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Gruß

M.O.

0 Punkte
Beantwortet von
Hallo M.O.

hab schon jetzt testen können. Ich habe mir eine Testdatei erstellt woraus zwei neue Tabellenblätter entstehen sollten. Leider hat das Makro die  Tabelle1 mit dem höchsten Wert umbenannt und überschrieben und keine weitere Tabelle erzeugt. Beim zweiten Test habe ich mit mehren unterschiedlichen Nummern gearbeitet. Das Ergebnis war, dass die Tabelle1 umbenannt wurde mit der höchsten Nummer und die Datensäte mit der niedrigsten Nummer gelöscht worden sind. Eine weitere Sortierung hat leider nicht statt gefunden.Besser wäre auch wenn die Tabelle1 nicht überschrieben wird.

Hast Du eine Idee wie man das lösen kann?

Ich danke dir schon mal!

Gruß Satt
0 Punkte
Beantwortet von m-o Profi (16.8k Punkte)

Hallo Satt,

bei meinen Test wurden die neuen Tabellenblätter angelegt und die Originaltabelle wurde nicht verändert.

Lade mal deine Beispieltabelle hoch, bei der es nicht geklappt hat. Eine Anleitung findest du hier: KLICK

Eine Sortierung der Daten vor der Trennung habe ich nicht eingebaut. Wenn du das willst, ist das aber auch kein Problem.

Gruß

M.O.

...