Aufgrund Spaltenbereich verschiedene Ranges erm.

Forumthread: Aufgrund Spaltenbereich verschiedene Ranges erm.

06.11.2012 21:34:37

Peter

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

Zeilenbereiche ermitteln und verarbeiten

07.11.2012 00:39:17

Erich

Hi Peter,
du willst Teilbereiche einer Spalte ermitteln und - mit den ganzen Zeilen - etwas tun.
Hier 4 Codes:


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

stitut1a ist im Prinzip dein Code,
stitut1b tut IMHO dasselbe wie dein Code.
stitut2 ermittelt eine Zellengruppe und verarbeitet (kopiert u.a.) sie sofort.
stitut3 sammelt die Zellengruppen in ein Array und verarbeitet sie in einer späteren Schleife.
Was du am ehesten gebrauchen kannst, hängt von deiner Anwendung ab.
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich

AW: Zeilenbereiche ermitteln und verarbeiten

07.11.2012 22:51:25

Peter

Hallo Erich
Deine Feststellung stimmt, dass dein kurzer 2. Code meinem geposteten Code entspricht. Mir war klar, dass mir da noch der wichtige Teil vom jeweiligen Übergang zu einem neuen String fehlt ...
Vielen Dank. Ich habe den 3. Code eingesetzt und er läuft prima. Eine Zusatzfrage: Weshalb muss varW als Variant dimensioniert werden?
Gruss, Peter
Option Explicit

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

AW: Zeilenbereiche ermitteln und verarbeiten

08.11.2012 01:38:17

Erich

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

AW: Zeilenbereiche ermitteln und verarbeiten

08.11.2012 08:02:02

Peter

Guten Tag Erich
Vielen Dank für alle Hinweise - ist sehr hilfreich!
In der neueren Vergangenheit habe ich eher versucht, mit an ThisWorkbook zu halten, weil mein Code in aller Regel in im Workbook enthalten ist, in welchem es ablaufen soll.
Die erwähnte Funktion bezieht sich auch auf ThisWorkbook:

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

Gruss, Peter

Beliebteste Forumthreads (12 Monate)

Aufgrund Spaltenbereich verschiedene Ranges erm.

Forumthread: Aufgrund Spaltenbereich verschiedene Ranges erm.

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

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread