Aufgrund Spaltenbereich verschiedene Ranges erm.

Guten Abend
In meinem Range "Liste" (bezieht sich auf eine Spalte, Inhalte aufsteigend sortiert) möchte ich jeweils die ganzen Zeilen eines bestimmten Inhalts einem Range zuweisen.
Anschliessend werde ich diese Zeilenbereiche (ermittelter Bereich, erweitert mit .EntireRow) in andere Tabellen kopieren.
Angenommen, die ersten Zellen des Range "Liste" sind wie folgt abgefüllt:
AAAA
AAAA
AAAA
CACC
CACC
DDDD
DDDD
Wie muss ich untenstehenden Code erweitern, dass mir zuerst der Range mit den 3 AAAA, dann derjenige mit zwei CACC und derjennige mit zwei DDDD ertellt?
Sehe im Moment nicht, wie ich das anstellen muss.
Danke und Gruss, Peter
For Each Rng In Range("Liste")
If rngListenCode Is Nothing Then
Set rngListenCode = Rng
Else
Set rngListenCode = Union(rngListenCode , Rng)
End If
Next

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub stitut1a() Dim rng As Range, rngListenCode As Range For Each rng In Range("Liste") If rngListenCode Is Nothing Then Set rngListenCode = rng Else Set rngListenCode = Union(rngListenCode, rng) End If Next End Sub Sub stitut1b() Dim rngListenCode As Range Set rngListenCode = Range("Liste") End Sub Sub stitut2() Dim varW As Variant, zz As Long, lngV As Long With Range("Liste") lngV = 1 varW = .Cells(1) For zz = 2 To .Rows.Count + 1 If .Cells(zz).Value varW Or zz = .Rows.Count + 1 Then ' Teil-Range verarbeiten MsgBox .Cells(lngV).Resize(zz - lngV).Address ' oder etwas anderes ' .Cells(lngV).Resize(zz - lngV).EntireRow.Copy ' oder etwas anderes varW = .Cells(zz) lngV = zz End If Next zz End With End Sub Sub stitut3() Dim varW As Variant, zz As Long, lngV As Long, arRng() As Range, lngA As Long ReDim arRng(1 To 5) With Range("Liste") lngV = 1 ' Teil-Ranges in Array sammeln varW = .Cells(1) For zz = 2 To .Rows.Count + 1 If .Cells(zz).Value varW Or zz = .Rows.Count + 1 Then lngA = lngA + 1 If lngA > UBound(arRng) Then ReDim Preserve arRng(1 To 2 * UBound(arRng)) Set arRng(lngA) = .Cells(lngV).Resize(zz - lngV) varW = .Cells(zz) lngV = zz End If Next zz If lngA > 0 Then ' Teil-Ranges verarbeiten ReDim Preserve arRng(1 To lngA) For zz = 1 To lngA MsgBox arRng(zz).EntireRow.Address ' arRng(zz).EntireRow.Copy Next zz End If End With End Sub

Sub Aufteilen() Dim varW As Variant, zz As Long, lngV As Long, WSh_Detail As Excel.Worksheet Dim Wbk As Excel.Workbook, strDetail As String Set Wbk = ThisWorkbook With Range("Liste") lngV = 1 varW = .Cells(1) For zz = 2 To .Rows.Count + 1 If .Cells(zz).Value varW Or zz = .Rows.Count + 1 Then strDetail = varW If Not IsSheetExisting(strDetail) Then Set WSh_Detail = ThisWorkbook.Worksheets.Add With WSh_Detail .Name = strDetail .Move after:=Sheets(Sheets.Count) End With Else Set WSh_Detail = Wbk.Worksheets(strDetail) End If '''Kopfzeile einfügen Worksheets("Uebersicht").Range("A1:A2").EntireRow.Copy Destination:=Sheets(strDetail).Range("A1" _ ) '''Detailzeilen einfügen .Cells(lngV).Resize(zz - lngV).EntireRow.Copy Destination:=Sheets(strDetail).Range("A3") varW = .Cells(zz) lngV = zz End If Next zz End With End Sub

Hi Peter,
varW muss nicht in jedem Fall als Variant deklariert (nicht 'dimensioniert') werden.
Die Variable soll ja jeweils den Vergleichswert aus Spalte A aufnehmen.
Bei dir sind das Strings, also sollte man varW als String deklarieren.
Nun hast du aber schon eine Variable (strDetail) mit dem selben Wert.
Du brauchst varW gar nicht, kannst den Vergleich mit strDetail erledigen.
Noch ein paar Bemerkungen. Das sind wohlgemerkt keine Fehler,
können aber teilweise leicht zu Fehlern führen:
Du deklarierst "As Excel.Worksheet" und "As Excel.Workbook". Wozu das "Excel."?
Man könnte ebenso gut "Application." schreiben - oder es einfach weglassen.
Du arbeitest mit der Variablen Wbk = ThisWorkbook. Aber nicht konsequent.
Später kommt trotzdem noch "ThisWorkbook" vor,
bei ".Move after:=Sheets(Sheets.Count)" fehlt die Angabe des Workbooks.
Auch bei "IsSheetExisting(strDetail)" wird wohl nicht klar sein,
in welchem Workbook die Existenz geprüft werden soll.
Also: Entweder ist Wbk nötig - dann musst du es immer angeben - oder es ist überflüssig.
Mein angehängter Code (in einem normalen Modul) arbeitet - da er nichts festlegt - auf dem ActiveWorkbook,
deiner teilweise auf ThisWorkbook, teilweise auf dem ActiveWorkbook.
Das ist ok, solange die beiden übereinstimmen, aber unschön, weniger 'sauber'.
Du arbeitest mit der Variablen WSh_Detail (Zielblatt).
Später kommt weiter "Sheets(strDetail)" statt "WSh_Detail".
Hier mein Vorschlag, der hoffentlich das selbe Resultat hat:


Sub Aufteilen()
Dim strDetail As String, zz As Long, lngV As Long, WSh_Detail As Worksheet
With Range("Liste")
lngV = 1
strDetail = .Cells(1)
For zz = 2 To .Rows.Count + 1
If .Cells(zz).Value  strDetail Or zz = .Rows.Count + 1 Then
If Not IsSheetExisting(strDetail) Then
Set WSh_Detail = Worksheets.Add(after:=Sheets(Sheets.Count))
WSh_Detail.Name = strDetail
Else
Set WSh_Detail = Sheets(strDetail)
End If
'''Kopfzeile einfügen
Sheets("Uebersicht").Rows(1).Copy Destination:=WSh_Detail.Rows(1)
'''Detailzeilen einfügen
.Cells(lngV).Resize(zz - lngV).EntireRow.Copy _
Destination:=WSh_Detail.Range("A3")
strDetail = .Cells(zz)
lngV = zz
End If
Next zz
End With
End Sub

Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich

Function IsSheetExisting(ShName As String) As Boolean Dim Sh As Object For Each Sh In ThisWorkbook.Sheets ‎ If LCase$(Sh.Name) = LCase$(ShName) Then _‎ ‎ IsSheetExisting = True: Exit Function Next End Function

Beliebteste Forumthreads (12 Monate)

Aufgrund Spaltenbereich verschiedene Ranges erm.

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread