Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Aufgrund Spaltenbereich verschiedene Ranges erm.

Betrifft: Aufgrund Spaltenbereich verschiedene Ranges erm. von: Peter
Geschrieben am: 06.11.2012 21:34:37

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

  

Betrifft: Zeilenbereiche ermitteln und verarbeiten von: Erich G.
Geschrieben am: 07.11.2012 00:39:17

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


  

Betrifft: AW: Zeilenbereiche ermitteln und verarbeiten von: Peter
Geschrieben am: 07.11.2012 22:51:25

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



  

Betrifft: AW: Zeilenbereiche ermitteln und verarbeiten von: Erich G.
Geschrieben am: 08.11.2012 01:38:17

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


  

Betrifft: AW: Zeilenbereiche ermitteln und verarbeiten von: Peter
Geschrieben am: 08.11.2012 08:02:02

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


 

Beiträge aus den Excel-Beispielen zum Thema "Aufgrund Spaltenbereich verschiedene Ranges erm."