Zeilen markieren wenn bestimmter Wert enthalten

Jan · 2012-12-05T14:42:28+00:00

Hallo, durch die Google-Suche bin ich auf dieses Forum aufmerksam geworden. Suche seit nach Stunden einer einfachen Makro-Lösung Zeilen mit einem bestimmten Wert zu markieren (leider fehlt mir selbst das Know-How in diesem Bereich). Vielleicht kann mir jemand helfen, bin bislang nur über ähnliche Probleme gestolpert und die machen mir dann nur alles bunt etc. Spalte A .... 2: ABC_1 ..... 3: ABC_1 ..... 4: ABC_2 ..... 5: ABC_2 ..... 6: ABC_2 ..... 7: ABC_3 ..... . . . In diesem Fall sollen also die Zeilen 2+3 markiert werden (die möchte ich dann in eine neue Excel-Tabelle kopieren und unter dem Namen ABC_1 speichern). Dann soll es weitergehen mit den Zeilen 4-6 (abgespeichert unter ABC_2) usw. Freue mich über jede Hilfe, da es kurzfristig ist und ich mir erst nochmal ein VB-Buch zulegen muss ;)

... seltsam, als ichs gestern getestet habe lief es noch!
Naja, etwas umgestrickt. Sollte jetzt laufen.
Anmerkung: die vielen _ am Zeilenende des letzten Codes hat der Herber-Codevorschau-Zeilenumbruch-Script verursacht, die sind für den Code nicht notwendig.

Option Explicit
Sub SaveManyFiles()
Dim iCol As Integer
Dim wksOld As Worksheet
Dim sPath As String
'Umbenennen! Wird bei dir ja nicht "Tabelle1" heissen
Set wksOld = Sheets("Tabelle1")
'Hier die SPALTE angeben in der die nächsten Dateinamen stehen! A = 1, B = 2
iCol = 1
'Hier werden die neuen Dateien gespeichert
sPath = "C:\TestTMP"
'Hier fängt der Code an!
Dim rDatei As Range
Dim lRowLast As Long
Dim lAnzDatei As Long
Dim wkbOld As Workbook
Dim wkbNew As Workbook
Dim iColLast As Integer
With wksOld
lRowLast = .Cells(Rows.Count, iCol).End(xlUp).Row
'letzte Zeile
iColLast = .UsedRange.Columns.Count
'Anzahl Spalten
For Each rDatei In Range(Cells(2, iCol), Cells(lRowLast, iCol))
'für den Bereich
lAnzDatei = Application.WorksheetFunction.CountIf(.Cells(1, iCol).EntireColumn,  _
rDatei.Value)   'so viele Datensätze dieses Names gibt es
If rDatei = "" Then _
'wenn leer dann nix! (Leer wenn gelöscht, siehe unten)
Else
Set wkbOld = ActiveWorkbook
'diese Datei merken
rDatei.Resize(lAnzDatei, iColLast).Copy
'gesamte Zeile kopieren
Workbooks.Add
'neues Excelsheet
Set wkbNew = ActiveWorkbook
'Focus liegt automatisch auf neuer Datei! Darum klappt "activeworkbook" nochmal
Range("A1").PasteSpecial
'einfügen
wkbNew.SaveAs Filename:=sPath & "\" & rDatei.Value & ".xls", FileFormat:=xlExcel8
'neue Datei speichern als *.xls
wkbNew.Close
'neue Datei schließen
rDatei.Resize(lAnzDatei, 1).EntireRow.ClearContents
'Datensatz aus alter Datei entfernen
End If
Next rDatei
End With
End Sub

Hi,
probier mal den.
Anmerkung: Das Ursprungsblatt muss sortiert sein!
also zum Beispiel das:
ABCD_1 - EFGH_1
ABCD_1 - EFGH_1
ABCD_1 - EFGH_2
ABCD_1 - EFGH_2
ABCD_1 - EFGH_1 (GAB SCHONMAL WEITER OBEN)
darf nicht passieren, sonst gibts nen Error!
Anmerkung zwei:
im Zweifelsfall funktioniert das:
Sheets("Tabelle1").Delete
Sheets("Tabelle2").Delete
Sheets("Tabelle3").Delete
nicht wie es soll. Ich hab englisches Exel, bei mir muss es heissen Sheets("Sheet1").delete Ich bin mir ziemlich, aber nicht 100% ig, sicher dass es im deutschen Excel "Tabelle1" heisst. Ausserdem weiss ich ja nicht, ob du überhaupt ein deutsches Excel hast :-)
Anmerkung 3: (für stille Mitleser, nicht für dich)
ja, ich lösche Datensätze aus einer laufenden Schleife und frage dann den neuen Inhalt auf "" ab. Mit ist bewusst dass das nicht ganz sauber ist und ab ein paar millionen Datensätzen auch zu unnötigen Performanceeinbrüchen führt. Hier solls reichen, und es ist recht einfach zu programmieren und hoffentlich auch einfach nachzuvollziehen. Meiner Meinung nach ist ein nachvollziehbarer Code eine bessere Hilfe als ein bis-ins-letzte optimierter Ablauf, den der Neuling gar nicht verstehen kann - und ja, ich war zu faul das optimal zu schreiben :-)
Grüße,
Klaus M.vdT.

Option Explicit
Sub SaveManyFiles()
Dim icol As Integer
Dim iColTable As Integer
Dim wksOld As Worksheet
Dim sPath As String
'Umbenennen! Wird bei dir ja nicht "Tabelle1" heissen
Set wksOld = Sheets("Tabelle1")
'Hier die SPALTE angeben in der die nächsten Dateinamen stehen! A = 1, B = 2
icol = 1
'und hier die SPALTE, in der die Tabellennamen stehen!
iColTable = 2
'Hier werden die neuen Dateien gespeichert
sPath = "C:\TestTMP"
'Hier fängt der Code an!
Dim rDatei As Range
Dim lRowLast As Long
Dim lAnzDatei As Long
Dim wkbOld As Workbook
Dim wkbNew As Workbook
Dim iColLast As Integer
With wksOld
lRowLast = .Cells(Rows.Count, icol).End(xlUp).Row
'letzte Zeile
iColLast = .UsedRange.Columns.Count
'Anzahl Spalten
For Each rDatei In Range(Cells(2, icol), Cells(lRowLast, icol))
'für den Bereich
lAnzDatei = Application.WorksheetFunction.CountIf(.Cells(1, icol).EntireColumn, _
rDatei.Value)   'so viele Datensätze dieses Names gibt es
If rDatei = "" Then _
'wenn leer dann nix! (Leer wenn gelöscht, siehe unten)
Else
Set wkbOld = ActiveWorkbook
'diese Datei merken
rDatei.Resize(lAnzDatei, iColLast).Copy
'gesamte Zeile kopieren
Workbooks.Add
'neues Excelsheet
Set wkbNew = ActiveWorkbook
'Focus liegt automatisch auf neuer Datei! Darum klappt "activeworkbook" nochmal
Range("A1").PasteSpecial
'einfügen
Call MakeManyTables(iColTable)
'hier wird das Makro aufgerufen, dass die Unteraufgabe erfüllt
wkbNew.SaveAs Filename:=sPath & "\" & rDatei.Value & ".xls", FileFormat:= _
xlExcel8
'neue Datei speichern als *.xls
wkbNew.Close
'neue Datei schließen
rDatei.Resize(lAnzDatei, 1).EntireRow.ClearContents
'Datensatz aus alter Datei entfernen
End If
Next rDatei
End With
End Sub
Sub MakeManyTables(iColNew As Integer)
Dim lRow As Long
Dim lAnzTable As Long
Dim wksOld As Worksheet
Set wksOld = ActiveSheet    'Blatt merken
Dim rTables As Range
lRow = Cells(Rows.Count, iColNew).End(xlUp).Row 'letzte Zeile
For Each rTables In Range(Cells(1, iColNew), Cells(lRow, iColNew))
If rTables.Value = "" Then
'nix! wenn leer dann nix!
Else    'aber sonst!
lAnzTable = Application.WorksheetFunction.CountIf(Cells(1, iColNew).EntireColumn,  _
rTables.Value)
'so viele Datensätze dieses Names gibt es
Cells(rTables.Row, 1).Resize(lAnzTable, Columns.Count).Copy 'kopieren
Sheets.Add          'neues sheet
With ActiveSheet    'das neu erstellte sheet ist automatisch "active"!
.Name = rTables.Value 'sheet umbenennen
.Range("A2").PasteSpecial
.Range("A1").Value = "Überschrift 1"    'Überschriften wirst du brauchen?
.Range("B1").Value = "Überschrift 2"    'ändere sie hier!
.Range("C1").Value = "Überschrift 3"    'wenns mehr als vier Spalten werden,
.Range("D1").Value = "Überschrift 4"    'einfach fortsetzen bis der Artzt kommt. _
End With
wksOld.Activate 'zurück zum alten Blatt
Cells(rTables.Row, 1).Resize(lAnzTable, Columns.Count).ClearContents 'alten  _
Datensatz löschen
End If
Next rTables
'* Dieser Block löscht die nun nicht mehr benötigten Tabellen 1, 2 und 3.
'* Das "DisplayAlerts" wird abgeschaltet, um das Fenster vom Excel
'* "da kann aber was in der Tabelle sein! Echt löschen?" zu verhindern
Application.DisplayAlerts = False
Sheets("Tabelle1").Delete
Sheets("Tabelle2").Delete
Sheets("Tabelle3").Delete
Application.DisplayAlerts = True
'* Block Tabellenlöschen Ende
End Sub

Zeilen markieren wenn bestimmter Wert enthalten

Forumthread: Zeilen markieren wenn bestimmter Wert enthalten

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial

Zeilen in Excel markieren, die einen bestimmten Wert enthalten

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)

Zeilen markieren wenn bestimmter Wert enthalten

Forumthread: Zeilen markieren wenn bestimmter Wert enthalten

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Infobox / Tutorial

Zeilen in Excel markieren, die einen bestimmten Wert enthalten

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)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread