Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
844to848
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
844to848
844to848
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Auf mehrere Tabellenblätter verteilen

Auf mehrere Tabellenblätter verteilen
20.02.2007 13:36:00
Roger
Hallo zusammen
Hab hier einen Super Code gefunden um Daten von einem Tabellenblatt auf mehrere aufzuzteilen. Das heisst alle Gruppenbezeichnungen in Spalte D zusammen in ein neues Blatt. Sowiet funtkioniert da ganz gut. Nur werden nur beim letzten Blatt die leerzeilen gelöscht bei den anderen aber nicht und ausserdem bleibt die Gruppe SAM auf dem ursprünglichen Blatt stehen.
hier mal der Code und die dazugehörige Datei.

Sub Zeile_in_neues_Blatt()
'Prozedur, in der eine zu durchsuchende Spalte abgefragt wird
'Die unterschiedlichen Begriffe, die gefunden werden,
'werden je in ein neues Blatt kopiert.
'Startzeile ist 2
Dim wkbBasis As Workbook
Dim wksBasis As Worksheet
Dim wksZiel As Worksheet
Dim wks As Worksheet
Dim intBlatter As Integer
Dim lngZeil As Long
Dim intRow As Integer
Dim varSuch As Variant
Dim varSpalt As Variant
Dim bolCut As Boolean
Dim lngCZeil As Long
Dim lngPZeil As Long
varSpalt = InputBox("Bitte die Spalte eingeben, die durchsucht werden soll.", "Suchspalte", "")
If IsEmpty(varSpalt) Then Exit Sub
If Not IsNumeric(varSpalt) Then Exit Sub
If CInt(varSpalt) > 255 Or CInt(varSpalt) < 0 Then Exit Sub
varSpalt = CByte(varSpalt)
Application.EnableEvents = False
Set wkbBasis = ActiveWorkbook
Set wksBasis = ActiveSheet
lngZeil = 2
Do
varSuch = wksBasis.Cells(lngZeil, varSpalt)
If wksBasis.Name = varSuch Then Exit Sub
wkbBasis.Sheets.Add after:=wksBasis
Set wksZiel = ActiveSheet
For Each wks In wkbBasis.Worksheets
If wks.Name = varSuch Then
Application.DisplayAlerts = False
wks.Delete
Application.DisplayAlerts = True
Exit For
End If
Next
wksZiel.Name = varSuch
lngCZeil = 2
lngPZeil = 2
Do
If wksBasis.Cells(lngCZeil, varSpalt) = varSuch Then
wksBasis.Cells(lngCZeil, 1).EntireRow.Cut Destination:=wksZiel.Cells(lngPZeil, 1)
wksBasis.Cells(lngCZeil, 1).EntireRow.Delete
bolCut = True
End If
If bolCut = False Then
lngCZeil = lngCZeil + 1
bolCut = True
Else
lngPZeil = lngPZeil + 1
bolCut = False
End If
Loop Until IsEmpty(wksBasis.Cells(lngCZeil, varSpalt))
lngZeil = lngZeil + 1
Loop Until IsEmpty(wksBasis.Cells(lngZeil, varSpalt))
Set wksZiel = Nothing
Set wkbBasis = Nothing
Application.EnableEvents = True
End Sub

https://www.herber.de/bbs/user/40564.xls
Ich hoffe es findet jemand den Fehler den es ist sehr mühsam jedes einzelene Blatt aufzurufen und dort die leerzeilen zu löschen.
Besten Dank und Gruss
Roger

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Auf mehrere Tabellenblätter verteilen
21.02.2007 08:12:00
Roger
Habs selber rausgefunden.
hab einfach bevor der Loop gemacht wird einen Befehl auf einen Code zum leere Zeilen löschen eingefügt und nun klappts wunderbar.
AW: Auf mehrere Tabellenblätter verteilen
22.02.2007 13:40:00
O.
Hallo Roger!
Danke für das Script, es passte wie die Faust auf's Auge!
Bist Du so nett und veröffentlichst auch noch die Zeile, die leere Zeilen löscht?
Oder Du stellst das Script nochmal vollständig zur Verfügung.
Vielen lieben Dank!
Gibt es eigentlich auch eine Variante, bei der nicht Tabellenblätter sondern separate Dateien erstellt und in ein bestimmtes Verzeichnis geschrieben werden? Das wäre noch besser ...
Gruß, Oliver
Anzeige
AW: Auf mehrere Tabellenblätter verteilen
22.02.2007 13:47:00
Roger
Hallo Oliver
leider bin ich auch kein Crack in VBA, aber hier mal den Code den ich auch hier gefunden habe zum zeilen löschen:

Sub Leerzeilenlöschen()
'   Leerzeilen löschen einschließlich der Zeilen die entstehen wenn Zeilen am ende
'   gelöscht werden, auch Leerzeilen in der Tabelle werden gelöscht
'   von Wolf.W.Radzinski
On Error Resume Next
Dim r As Range
Dim anz As Long
Dim c_ges As Long
Dim col As New Collection
c_ges = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
For Each r In ActiveSheet.UsedRange.EntireRow
anz = 0
anz = r.SpecialCells(xlCellTypeBlanks).Count
If anz >= c_ges Then col.Add r
Next
For Each r In col
r.Delete
Next
End Sub

Gruss Roger
Anzeige
AW: Auf mehrere Tabellenblätter verteilen
22.02.2007 13:56:42
O.
Danke!

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige