✔ Makro VBA Suche findet nur 1 Element

[Thorsten1]

Hallo,

ich bin grade dabei eine bei einer Bestehenden Raumliste (2000 Räume) eine Übersicht zu erstellen die anzeigt welcher Raum zu welchem Mieter gehört jedoch weiß ich nicht wie ich meine Suchfunktion bearbeiten muss das die Suchfunktion alle Räume anzeigt:

Im Momment bekomm ich nur folgendes Ergebnis:

Mieter / Räume im UG
Mieter1: / ,1

edit: irgendwas bei der do loop schleife stimmt nicht oder die suchergebnisse müssen besser abgefangen werden?

edit2: eben ist mir die idee gekommen in das "Range("B1:B" & maxrows).Select" eine schleife einzubauen irgendwie so: "Range("B" & i & ":B" & maxrows).Select"

Sub Makro1()
On Error GoTo errorhandler
 
Dim rng As Range
Dim bolGefunden As Boolean
Dim Mieter As String
Dim i As Integer
i = 0
Dim Buffer1 As String
 
Sheets("Übersicht").Activate
Mieter = Cells(2, 1)
 
Sheets("UG").Activate
 
maxrows = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
Range("B1:B" & maxrows).Select

Do
    Set rng = Selection.Find(What:=Mieter, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, _
                             SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                             MatchCase:=False, SearchFormat:=False)
    bolGefunden = Not rng Is Nothing
    If bolGefunden Then
        Position = rng.Address
 
        Range(Position).Select
                wertx = ActiveCell.Row
                werty = ActiveCell.Column - 1
        Buffer1 = Cells(wertx, werty)
        MsgBox (Buffer1)

    Sheets("Übersicht").Activate
    Cells(2, 2) = Cells(2, 2) & "," & Buffer1
    i = i + 1
    If i = 10 Then GoTo errorhandler
 
    End If
Loop While bolGefunden
MsgBox ("Finshed")
Exit Sub

errorhandler:
If Err.Number = 91 Then 'Programm findet das gesuchte Wort nicht mehr
Else
MsgBox (Err.Number & " " & Err.Description)
End If
End Sub

Wär sehr dankbar wenn mir jemand erklären könnte was man da ändern muss, den rest sollte ich hinbekommen.

Grüße Thorsten

 

[Thorsten1]

So hat sich fast erledigt,

ich weiß der code sieht schrecklich aus, aber er funktioniert..^^

Komischerweiße funktioniert es manchmal! nicht, wenn ein Mieter direkt 2 Räume hintereinander hat (einer geht verlorren...)

Als beispiel:
Range(A1:A3) ist markiert, alle Zellen enthalten jeweils A1/A2/A3=Mieter1.
Dann zeigt die Suche als erstes Ergebnis A2 an ? und das obwohl A1 auch markiert ist.

Sub Makro1()
On Error GoTo errorhandler
 
Dim rng As Range
Dim bolGefunden As Boolean
Dim Mieter As String
Dim Etagen As Integer
Etagen = 1
Dim Mieternr As String
Mieternr = 1
Dim i As Integer
Dim l As Integer
i = 0
l = 1
Dim Buffer1 As String
 
Sheets("Übersicht").Activate
Mieter = Cells(2, 1)
 
maxrows = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
Range("B1:B" & maxrows).Select

Do
    If Etagen = 1 Then
        Sheets("UG").Activate
            ElseIf Etagen = 2 Then
        Sheets("EG").Activate
            ElseIf Etagen = 3 Then
        Sheets("1.OG").Activate

        End If
    maxrows = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    Range("B" & l & ":B" & maxrows + 1).Select
    Set rng = Selection.Find(What:=Mieter, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, _
                             SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                             MatchCase:=False, SearchFormat:=False)
    bolGefunden = Not rng Is Nothing
    If bolGefunden Then
        Position = rng.Address
        Range(Position).Select
        wertx = ActiveCell.Row
        l = ActiveCell.Row + 1
        werty = ActiveCell.Column - 1
        Buffer1 = Cells(wertx, werty)
        'MsgBox (Buffer1)
        Sheets("Übersicht").Activate
            If Cells(1 + Mieternr, 2) = "" Then
                Cells(1 + Mieternr, 2) = Buffer1
            Else
                Cells(1 + Mieternr, 2) = Cells(1 + Mieternr, 2) & "," & Buffer1
            End If
        i = i + 1
        If i = 50 Then GoTo errorhandler
    End If
    
    If bolGefunden = False And Etagen <> 4 Then
        Etagen = Etagen + 1
        bolGefunden = True
        If Etagen = 2 Then
        l = 1
            ElseIf Etagen = 3 Then
        l = 1
            ElseIf Etagen = 4 And Mieternr <> 5 Then
        l = 1
            Mieternr = Mieternr + 1
            Etagen = 1
            Sheets("Übersicht").Activate
            Mieter = Cells(1 + Mieternr, 1)
        End If
    End If
Loop While bolGefunden
MsgBox ("Finshed")
Exit Sub

errorhandler:
If Err.Number = 91 Then 'Programm findet das gesuchte Wort nicht mehr
Else
MsgBox (Err.Number & " " & Err.Description)
End If
End Sub

 

[tombe]

Muss es den unbedingt ein Makro sein? Mit der SUMMEWENN-Funktion ist das recht einfach zu lösen (zumindest wenn ich es richtig verstanden habe).

Ich hänge mal ein Beispiel dran wie ich es gelöst habe. Wichtig ist hier nur die Spalte C in den Blättern UG, EG und 1OG, da mit dieser Spalte gerechnet wird. Kann zur Not auch ausgeblendet werden.

 

[Thorsten1]

Haha Warum einfach wenns auch schwer geht?^^

Vielen Dank, die SUMMEWENN-Funktion hatte ich bis jetzt noch nie benutzt.
Am Ende läufts jetzt doch mit dem Makro da einige Raumbeschreibungen noch Zusatzinformationen enthalten, Trotzdem danke für diesen schicken netten Code

Grüße Thorsten