Excel VBA: Schleife, CurrentRegion und Range.Find-Methode

[MirkoP]

Hallo an alle Excel-Freunde,
nach langem Hin- und Herprobieren bitte ich wirklich um Hilfe durch das Forum , da ich bei meinem VBA-Code, der mittlerweile recht lang und komplex geworden ist, nicht mehr weiter weiß. Rein formal stimmt der VBA-Code, doch er rechnet mir nicht.

- Ich habe drei Tabellenblätter namens "Garagenmieter", "Kontoauszüge" und "Hilfstabelle".
- Im Blatt "Garagenmieter" stehen in Spalte "A" ab "A6"die Kontonummern der Garagenmieter drinnen.
- Im Blatt "Kontoauszüge" stehen sämtliche Konten der Mieter, u.a. auch jene der Garagenmieter und deren Kontonummern in Spalte "B".
- Im Blatt "Hilfstabelle" steht in Zelle "B21" das aktelle Monat der Abrechnung drinnen, z.B. "8" für den Monat August.
- Im Blatt "Garagenmieter" stehen u.a. auch die Mietforderungen. Die Monate der semestralen Mietforderungen stehen in den Spalten "I" und "J".

1. Schritt: Eine Schleife für Blatt "Garagenmieter" Spalte "A" einbauen und suchen mit der Range.Find-Methode in Tabelle "Kontoauszüge", d.h. ich suche die Kontonummer des Garagenmieters im Blatt "Kontoauszzüge", um das richtige Konto anzusteuern.
2. Schritt: Ich bilde eine CurrentRegion für das betreffende Mieterkonto; oberhalb und unterhalb des Mieterkontos befinden sich leere Zeilen.
3. Schritt: Über ein Array suche ich die Zelle, in der "Mietforderung" steht. Diese steht immer in Spalte "D"; In Spalte "E" steht dann der Betrag, den es zu ändern gilt. -> über Offset(0, 1) anzusteuern
 
Es gilt: Wenn sich der aktuelle Monat (Hilfstabelle B21) zwischen dem ersten und letzten Zahlmonat befindet (zwischen den Werten der Zellen E und F im Blatt "Gargenmieter"), dann befindet sich der neue Wert der Mieteinnahmen in Blatt "Garagenmieter" Spalte "I" -> IF ...
 
Es gilt auch: Wenn der aktuelle Monat (Hilfstabelle B21) größer oder gleich des letzten Zahlmonats ist(>= F im Blatt "Garagenmieter"), dann befindet sich der neue Wert der Mieteinnahmen in Blatt "Garagenmieter" Spalte "J" -> ElseIf...
 
Wie gesagt: Formal ist mein VBA in Ordnung, aber es rechnet nicht. Vielleicht kann sich jemand die Zeit nehmen, sich meines Problems anzunehmen.
Ich danke jedem Leser und v.a. jenem, der mir weiterhelfen kann.

Vilen Dank schon mal im voraus und schöne Grüße, Mirko
 
Und hier mein Code:
________________________
 

Code:

Sub Garagenmieter()
 
Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim lngZ As Long
Dim lngZZ As Long
 
Set wksQ = Worksheets("Garagenmieter") 'Quellblatt
Set wksZ = Worksheets("Kontoauszüge") 'Zielblatt
lngZZ = 2
 
With wksQ
 For lngZ = 6 To .Range("A65536").End(xlUp).Row
 
   If wksQ.Cells(lngZ, 1) = wksZ.Cells(lngZZ, 2) And Sheets("Hilfstabelle").Range("B21") <= wksQ.Cells(lngZ, 5) < wksQ.Cells(lngZ, 6) Then
   wksZ.Cells(lngZZ, 2).Select
  
' Einbau CurrentRange-Absatz
    Dim FirstAddress As String
        Dim myArr As Variant
        Dim Rng As Range
        Dim O As Long
 
        With Application
        .ScreenUpdating = False
        .EnableEvents = False
        End With
 
            myArr = Array("*Mietforderung*")
 
        With ActiveCell.CurrentRegion
 
            For O = LBound(myArr) To UBound(myArr)
 
                Set Rng = .Find(What:=myArr(O), _
                    After:=.Cells(.Cells.count), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)
 
                If Not Rng Is Nothing Then
                FirstAddress = Rng.Address
                Do
                    Rng.Offset(0, 1).Value = wksQ.Cells(lngZ, 9)
                Set Rng = .FindNext(Rng)
                Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
            End If
        Next O
    End With
    ElseIf wksQ.Cells(lngZ, 1) = wksZ.Cells(lngZZ, 2) And Sheets("Hilfstabelle").Range("B21") >= wksQ.Cells(lngZ, 6) Then
   wksZ.Cells(lngZZ, 2).Select
  
 
    Dim FirstAddress1 As String
        Dim myArr1 As Variant
        Dim Rng1 As Range
        Dim O1 As Long
 
        With Application
        .ScreenUpdating = False
        .EnableEvents = False
        End With
 
            myArr1 = Array("*Mietforderung*")
 
        With ActiveCell.CurrentRegion
 
            For O1 = LBound(myArr1) To UBound(myArr1)
 
                Set Rng1 = .Find(What:=myArr(O), _
                    After:=.Cells(.Cells.count), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)
 
                If Not Rng1 Is Nothing Then
                FirstAddress1 = Rng1.Address
                Do
                    Rng1.Offset(0, 1).Value = wksQ.Cells(lngZ, 9) + wksQ.Cells(lngZ, 10)
                Set Rng1 = .FindNext(Rng1)
                Loop While Not Rng1 Is Nothing And Rng1.Address <> FirstAddress1
            End If
        Next O1
    End With
    End If
    Next
 End With
 
End Sub

[snb]

Bitte, verwende Code Tags und lade mal eine Beispieldatei hoch (mit Wunschergebnis)

[MirkoP]

Hallo,
anbei schicke ich eine Beispieldatei zu.
Wegen CodeTags bin ich momentan überfragt ...
Schöne Grüße,
Mirko

[Lutz Fricke]

Hallo Mirko,

so auf die Schnelle würde ich annehmen, dass Dein Makro nichts macht, da der Begriff

Code:

If wksQ.Cells(lngZ, 1) = wksZ.Cells(lngZZ, 2)

erst wahr wird, wenn Deine Garagenmieter-Liste abgearbeitet ist...

Schon mal in Einzelschrittmodus probiert?

Codetags werden durch das Icon in der 2 Zeile, 5. von rechts erzeugt. Damit erscheint Dein Code in einem separaten Fensterchen...

Gruß,
Lutz

[MirkoP]

Hallo Lutz,
vielen Dank für deinen Beitrag. Nun hab ich's begriffen mit dem Tag-Code. Ich füge dir meinen Code nochmals ein.
Du wirst recht haben, dass mir der Code gar nicht startet...

Code:

Sub Garagenmieter()

Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim lngZ As Long
Dim lngZZ As Long

Set wksQ = Worksheets("Garagenmieter") 'Quellblatt
Set wksZ = Worksheets("Kontoauszüge") 'Zielblatt
lngZZ = 2

With wksQ
For lngZ = 6 To .Range("A65536").End(xlUp).Row

   If wksQ.Cells(lngZ, 1) = wksZ.Cells(lngZZ, 2) And Sheets("Hilfstabelle").Range("B21") <= wksQ.Cells(lngZ, 5) < wksQ.Cells(lngZ, 6) Then
   wksZ.Cells(lngZZ, 2).Select

'   Einbau CurrentRange-Absatz
    Dim FirstAddress As String
        Dim myArr As Variant
        Dim Rng As Range
        Dim O As Long

        With Application
        .ScreenUpdating = False
        .EnableEvents = False
        End With

            myArr = Array("*Mietforderung*")

        With ActiveCell.CurrentRegion

            For O = LBound(myArr) To UBound(myArr)

                Set Rng = .Find(What:=myArr(O), _
                    After:=.Cells(.Cells.count), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)

                If Not Rng Is Nothing Then
                FirstAddress = Rng.Address
                Do
                    Rng.Offset(0, 1).Value = wksQ.Cells(lngZ, 9)
                Set Rng = .FindNext(Rng)
                Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
            End If
        Next O
    End With
    ElseIf wksQ.Cells(lngZ, 1) = wksZ.Cells(lngZZ, 2) And Sheets("Hilfstabelle").Range("B21") >= wksQ.Cells(lngZ, 6) Then
   wksZ.Cells(lngZZ, 2).Select


    Dim FirstAddress1 As String
        Dim myArr1 As Variant
        Dim Rng1 As Range
        Dim O1 As Long

        With Application
        .ScreenUpdating = False
        .EnableEvents = False
        End With

            myArr1 = Array("*Mietforderung*")

        With ActiveCell.CurrentRegion

            For O1 = LBound(myArr1) To UBound(myArr1)

                Set Rng1 = .Find(What:=myArr(O), _
                    After:=.Cells(.Cells.count), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)

                If Not Rng1 Is Nothing Then
                FirstAddress1 = Rng1.Address
                Do
                    Rng1.Offset(0, 1).Value = wksQ.Cells(lngZ, 9) + wksQ.Cells(lngZ, 10)
                Set Rng1 = .FindNext(Rng1)
                Loop While Not Rng1 Is Nothing And Rng1.Address <> FirstAddress1
            End If
        Next O1
    End With
    End If
    Next
End With

End Sub

[MirkoP]

Hallo Lutz, nochmals ich,
ich konnte in der Zwischenzeit am VBA herumbasteln und wie es aussieht, hat er jetzt geklappt!
Ich hatte wksZ nicht definiert und habe zudem die If- und ElseIf-Bedingungen abgeändert bzw. vereinfacht.
Vollständigkeitshalber auch die endgültige Excel-Tabelle zum uploaden.
Ich danke dir für all deine Inputs!
Schöne Grüße, Mirko

Code:

Sub Garagenmieter()

Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim lngZ As Long
Dim lngZZ As Long

Set wksQ = Worksheets("Garagenmieter") 'Quellblatt
Set wksZ = Worksheets("Kontoauszüge") 'Zielblatt
lngZZ = 2

With wksQ
For lngZ = 6 To .Range("A65536").End(xlUp).Row

With wksZ
    For lngZZ = 5 To .Range("A65536").End(xlUp).Row
   
   If wksQ.Cells(lngZ, 1) = wksZ.Cells(lngZZ, 2) And Sheets("Hilfstabelle").Range("B21") < wksQ.Cells(lngZ, 6) Then
   wksZ.Cells(lngZZ, 2).Select

'   Einbau CurrentRange-Absatz
    Dim FirstAddress As String
        Dim myArr As Variant
        Dim Rng As Range
        Dim O As Long

        With Application
        .ScreenUpdating = False
        .EnableEvents = False
        End With

            myArr = Array("*Mietforderung*")

        With ActiveCell.CurrentRegion

            For O = LBound(myArr) To UBound(myArr)

                Set Rng = .Find(What:=myArr(O), _
                    After:=.Cells(.Cells.count), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)

                If Not Rng Is Nothing Then
                FirstAddress = Rng.Address
                Do
                    Rng.Offset(0, 1).Value = wksQ.Cells(lngZ, 9)
                Set Rng = .FindNext(Rng)
                Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
            End If
        Next O
    End With
    ElseIf wksQ.Cells(lngZ, 1) = wksZ.Cells(lngZZ, 2) And Sheets("Hilfstabelle").Range("B21") >= wksQ.Cells(lngZ, 6) Then
   wksZ.Cells(lngZZ, 2).Select


    Dim FirstAddress1 As String
        Dim myArr1 As Variant
        Dim Rng1 As Range
        Dim O1 As Long

        With Application
        .ScreenUpdating = False
        .EnableEvents = False
        End With

            myArr1 = Array("*Mietforderung*")

        With ActiveCell.CurrentRegion

            For O1 = LBound(myArr1) To UBound(myArr1)

                Set Rng1 = .Find(What:=myArr(O1), _
                    After:=.Cells(.Cells.count), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)

                If Not Rng1 Is Nothing Then
                FirstAddress1 = Rng1.Address
                Do
                    Rng1.Offset(0, 1).Value = wksQ.Cells(lngZ, 12)
                    'Cells(Zeile, 195) = Application.Sum(Range(Cells(Zeile, 1), Cells(Zeile, 60)))
                Set Rng1 = .FindNext(Rng1)
                Loop While Not Rng1 Is Nothing And Rng1.Address <> FirstAddress1
            End If
        Next O1
    End With 'Für with CurrentRegion
    End If
    Next
End With
Next
End With

End Sub

[Lutz Fricke]

Hallo Mirko,

ich habe mir (als Laie) Deinen Code mal angesehen und dazu einige Anmerkungen:

Code:

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

ist ganz nett, bringt aber bei so einem kurzen Makro nichts.
ABER!!! Wenn Du an den Parametern drehst, MUSST Du sie am Ende des Makros auch wieder auf Ausgangsstellung bringen!!

Wozu definierst Du die Arrays myArr und myArr1 und machst die Schleife O=LBound... auf? Hast Du mehr Texte nach denen Du suchen willst?

Ist Dein Ziel wirklich, jedesmal, wenn Du den Text "Mietforderung" findest, Werte in die Tabelle zu schreiben? Wenn im Block von Hr. Rossi, "Mietforderung" doppelt steht, schreibsz Du die Zahlen auch zweimal rein.

Warum hast Du den identischen Code im If- und Elseif-Teil (was passiert bei Else?). Das Suchen nach "Mietforderung" etc. ist doch identisch, nur der gezogene Wert ist unterschiedlich.
Also "Mietforderung" suchen und DANN die IF-Abfrage und da kurz rein, von wo Dein Wert kommt. Erspart Dir auch deine (ohnehin) unnötige doppelte Definition aller Variablen.

Gruß,
Lutz

[MirkoP]

Hallo Lutz,
vielen Dank für deine Rückmeldung.
Ich gebe Dir recht, dass es nichts bringt, wenn ich das screenupdating = falsch einschreibe; schließlich endet die Schleife in nicht einmal einem Augenzwinkern. Ich werde sie herausnehmen.
Wegen der If- und Elseif-Bedingung: Beide sind bis auf dem Kleiner-Größer-Zeichen ident:

Code:

If ...  And Sheets("Hilfstabelle").Range("B21") < wksQ.Cells(lngZ, 6) Then

Code:

ElseIf ... And Sheets("Hilfstabelle").Range("B21") >= wksQ.Cells(lngZ, 6) Then

Aus meiner Sicht werde ich schon ein "Elseif" einbauen müssen, denn ich mache eine zweite Schleife auf, wenn die Kontonummer der Garagenmieter mit der Kontonummer innerhalb der Kontoauszüge koreliert.

Betreffend meines Arrays: Ich möchte nur eine Zelle  mit "Mietforderung" ansteuren; das mit dem L-Bound und U-Bound habe ich so im Internet gefunden; ich muss mir eben auch so weiterhelfen, da ich keine fortgeschrittenen VBA-Kenntnisse besitze. Aber ich bin für jeden Iput dankbar, so lernt man am meisten.

Ich hätte noch eine Frage an Dich und wäre für einen Tipp sehr dankbar:
Ich habe ein Mietkonto, das drei Zeilen von Mietforderungen beinhaltet; dies ist wirklich nur ein Mieter unter all den Garagenmietern. Bei meinem vorigem Code ändert es mir natürlich den Sollbetrag bei allen dreien. Wie kann ich das Array schreiben, dass es mir nur die Zelle in der zweiten Zeile ansteuert? Weiters ändert sich jährlich die Jahreszahl im Text.

[
Bild bitte so als Datei hochladen: Klick mich!
]

Schöne Grüße, Mirko

---

... Entschuldigung; ich wusste nicht, dass es keine Grafiken anzeigt:
Hier die Zeilenbeschreibungen in Spalte D des einen Kontos

Code:

Mietforderung 20 Thomas B.
Mietforderung 20 Thomas B. - Garage
Mietforderung 20 Thomas B. - Freifläche

Danke und Grüße, Mirko

---

Hallo Lutz,
ich habe in der Zwischenzeit den Ausdruck für die Suche von zwei Begriffen im Array gefunden:

Code:

Array("*Mietforderung*" & "*Garage*")

Vielen Dank!
Mirko

[Lutz Fricke]

Hallo Mirko,

ich habe mal etwas durchgeräumt. Bevor wir lange hin. und herdiskutieren, hier der Code:

Code:

Option Explicit

Sub Garagenmieter()

Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim lngZ As Long
Dim lngZZ As Long

Set wksQ = Worksheets("Garagenmieter") 'Quellblatt
Set wksZ = Worksheets("Kontoauszüge") 'Zielblatt
'lngZZ = 2

With wksQ
    For lngZ = 6 To .Range("A65536").End(xlUp).Row
   
        With wksZ
            For lngZZ = 5 To .Range("A65536").End(xlUp).Row
       
                If wksQ.Cells(lngZ, 1) = wksZ.Cells(lngZZ, 2) Then
                'And Sheets("Hilfstabelle").Range("B21") < wksQ.Cells(lngZ, 6) Then
                   wksZ.Cells(lngZZ, 2).Select
               
                '   Einbau CurrentRange-Absatz
                    Dim FirstAddress As String
                    Dim myArr As Variant
                    Dim Rng As Range
                    Dim O As Long
           
            '        With Application
            '        .ScreenUpdating = False
            '        .EnableEvents = False
            '        End With
           
            ' **** unnötig ***
            '   myArr = Array("*Mietforderung*")
           
                    With ActiveCell.CurrentRegion
               
                    ' **** unnötig ***
                    '            For O = LBound(myArr) To UBound(myArr)
    '                   Set Rng = .Find(What:=myArr(O), _

                        Set Rng = .Find(What:=myArr("*Mietforderung*"), _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
       
                        If Not Rng Is Nothing Then
                            FirstAddress = Rng.Address
                            Do
                           
If Sheets("Hilfstabelle").Range("B21") < wksQ.Cells(lngZ, 6) Then
                    Rng.Offset(0, 1).Value = wksQ.Cells(lngZ, 9)
ElseIf Sheets("Hilfstabelle").Range("B21") >= wksQ.Cells(lngZ, 6) Then
                    Rng1.Offset(0, 1).Value = wksQ.Cells(lngZ, 12)
End If
                                Set Rng = .FindNext(Rng)
                            Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
                        End If
            ' **** unnötig ***
            '        Next O
                    End With
                   
                   
                End If
            Next lngZZ
        End With
    Next lngZ
End With

End Sub

Der Code sollte weiterhin wie zuvor funktionieren.
Ich habe:
- das Array rausgenommen
- If-Abfrage auf zwei geteilt
   - 1) Kontoabfrage
   - 2) Datumsabfrage
- die Next's mit Variablen versehen

Bezüglich der neuen Anforderung muss ich probieren. Was ist die wirkliche Anforderung, zweites Auftreten oder Textbaustein "Garage"?

Gruß und schönes Wochenende,
Lutz

[snb]

Reicht schon und ist viel schneller:

Code:

Sub M_snb()
  sn = Sheets("Garagenmieter").Cells(1).CurrentRegion
  sp = Sheets("Kontoauszüge").Cells(1).CurrentRegion
  y = Sheets("Hilfstabelle").Cells(21, 2)
 
  With CreateObject("scripting.dictionary")
    For j = 6 To UBound(sn)
    .Item(sn(j, 1)) = Application.Index(sn, 1, 0)
    Next

    For j = 5 To UBound(sp)
      st = .Item(sp(j, 2))
      sp(j, 3) = st(6 + (y >= sp(j, 6)))
    Next
  End With
 
  Sheets("Kontoauszüge").Cells(1).CurrentRegion = sp
End Sub