Microsoft Excel

Herbers Excel/VBA-Archiv

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

da .. Makro bis Ende | Herbers Excel-Forum


Betrifft: da .. Makro bis Ende von: Mike
Geschrieben am: 21.12.2009 08:04:15

Guten Morgen,

da die nachfolgende Geschichte leider noch nicht erledigt ist, erlaube ich mir,
sie noch einmal aufzugreiffen.

https://www.herber.de/forum/archiv/1120to1124/t1123239.htm#1123305

(Beispielsdatei ist dabei)

Fact ist: In einer Endlosliste wird - um unnötige Zeilen zu löschen - nach "Gebühren" gesucht
und verschiedene Zeilen mit einem x markiert, die später mittels Autofilter gelöscht werden.

Um das Makro nicht immer wieder starten zu müssen, wäre es schön, wenn es bis zum Ende
(letzte "Gebühren" durchlaufen würde).

Besten Dank für Eure Ideen.

Gruss
Mike

  

Betrifft: AW: da .. Makro bis Ende von: fcs
Geschrieben am: 21.12.2009 11:54:57

Hallo Mike,

aus der ursprünglichen Frage blicke ich nicht durch, welche Zellen relativ zu den Fundzellen einen Eintrag "X" bekommen sollen.

ImPrinzip kannst du wie folgt eine Suchschleife aufbauen.

Gruß
Franz

Sub Markieren()
  'Sucht nach Begriffen in SPalte 6 (F) und setzt eine oder mehrere Markierungen
  On Error GoTo Fehler
  With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
  End With
  If fncSuchen(vFind:="GEBÜHREN", SuchBereich:=ActiveSheet.Columns(6)) _
      = False Then GoTo Fehler
  If fncSuchen(vFind:="P R I M", SuchBereich:=ActiveSheet.Columns(6)) _
      = False Then GoTo Fehler
  If fncSuchen(vFind:="ÜBER- / UN", SuchBereich:=ActiveSheet.Columns(6)) _
      = False Then GoTo Fehler
  MsgBox "Markierung abgeschlossen", vbInformation + vbOKOnly, "Spezialsuche"
Fehler:
  With Err
    Select Case .Number
      Case 0 'Null Probleme
      Case Else
        MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
    End Select
  End With
  With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
  End With
End Sub

Function fncSuchen(vFind As Variant, SuchBereich As Range, _
    Optional vMarker As Variant = "X") As Boolean
  Dim sAdresse1, Zelle As Range
  On Error GoTo Fehler
  fncSuchen = True
  Set Zelle = SuchBereich.Find(what:=vFind, LookIn:=xlValues, lookat:=xlPart)
  If Zelle Is Nothing Then
    MsgBox "Suchbegriff """ & vFind & """ wurde nicht gefunden", _
          vbInformation + vbOKOnly, "Spezialsuche"
  Else
    sAdresse1 = Zelle.Address '1. Fundstelle merken
    Do
      With Zelle
        Select Case vFind
          Case "GEBÜHREN"
            'Zellen, die relativ zu Zellen mit "GEBÜHREN " markiert werden sollen
            .Offset(1, -2).Resize(10).Value = "x"
            .Offset(73, -2).Resize(9).Value = "x"
            .Offset(86, -2).Value = "x"
            .Offset(89, -2).Value = "x"
            .Offset(129, -2).Resize(15).Value = "x"
          Case "P R I M"
            'Zellen, die relativ zu Zellen mit "P R I M" markiert werden sollen
            .Offset(-11, -2).Range("A1") = "x"
            .Offset(1, 0).Range("A1") = "x"
            .Offset(2, 0).Range("A1") = "x"
          Case "ÜBER- / UN"
            'Zellen, die relativ zu Zellen mit "ÜBER- / UN " markiert werden sollen
            .Offset(13, -2).Range("A1") = "x"
            .Offset(1, 0).Range("A1") = "x"
          Case Else
            MsgBox "Für Suchbegriff """ & vFind & _
              """ wurde keine Case-Anweisung mit den zu markierenden Zellen erstellt", _
              vbInformation + vbOKOnly, "Spezialsuche"
        End Select
      End With
      'Neue Suche
      Set Zelle = SuchBereich.FindNext(After:=Zelle)
    Loop Until Zelle Is Nothing Or Zelle.Address = sAdresse1
  End If
Fehler:
  If Err.Number <> 0 Then
    fncSuchen = False
    MsgBox "Fehler-Nr.: " & Err.Number & vbLf & Err.Description, _
        vbInformation, "Fehler in fcSuchen"
  End If
End Function



  

Betrifft: wow .. Makro bis Ende von: Mike
Geschrieben am: 21.12.2009 13:06:11


Hey Frank,

wow, perfekt gelöst, besten Dank für Deine schnelle
Hilfe! Das ist der Hammer!!

Gruss
Mike