Zahlenbereiche, Suchen & Ersetzen in einem Sub

Hallo, liebe Spezis!
Seit 4 Wochen suche ich nun schon mittelschwer verzweifelt in zig Foren und komme mit meinem Problem partout nicht weiter. Ich möchte mehrere Dinge mit einem Makro ausführen lassen.
Diese wären:
1. Zeilenlöschung: Lösche alle Zeilen ersatzlos bei denen in Spalte A keine Zahl zwischen 150 und 590 steht. Spalte A kann also leer sein oder es kann auch etwas anderes drin stehen.
2. Begriffslöschung: Lösche bestimmte Begriffe (ca. 20 verschiedene) ersatzlos (z. B. "Traber" oder "Derby"). Diese können in der gesamten Arbeitsmappe vorkommen.
3. Begriffsersetzungen: Ersetze bestimmte Begriffe (ca. 10 verschiedene) durch "ja". Diese können ebenfalls in der gesamten Arbeitsmappe vorkommen.
4. Summenbildung: In den Spalten G und H stehen natürliche Zahlen. Diese sollen in Spalte F (also auf Zeilenebene) als Summenformel zusammengefasst werden. Zum Beispiel können die Werte so aussehen: Spalte G=2, Spalte H=1. Es soll dann NICHT "3" stehen, sondern "2+1".
Es wäre toll, wenn mir jemand helfen könnte!
Dankeschön im Voraus! Hans

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Hans,
probier mal.

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit


Sub allesLoeschen()
Dim objWS As Worksheet
Dim varDelete As Variant, varReplace As Variant
Dim objDelete As Range, objRng As Range, objR As Range
Dim lngIndex As Long

On Error GoTo ErrorHandler

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

varDelete = Array("Traber", "Derby")        'Begriffe die gelöscht werden sollen.
varReplace = Array("Hund|Ja", "Katze|Nein") 'Begriffe die ersetzt werden sollen Begriff|Ersatz !

For Each objWS In ThisWorkbook.Worksheets
  With objWS
    'Zeilen löschen
    On Error Resume Next
    Set objRng = .Columns(1).SpecialCells(xlCellTypeConstants, xlTextValues)
    If Not objRng Is Nothing Then objRng.EntireRow.Delete
    Set objRng = Nothing
    Set objRng = .Columns(1).SpecialCells(xlCellTypeConstants, xlNumbers)
    If Not objRng Is Nothing Then
      For Each objR In objRng
        If objR < 150 Or objR > 590 Then
          If objDelete Is Nothing Then
            Set objDelete = objR
          Else
            Set objDelete = Union(objDelete, objR)
          End If
        End If
      Next
      If Not objDelete Is Nothing Then objDelete.EntireRow.Delete
      Set objRng = Nothing
      Set objRng = .Columns(1).SpecialCells(xlCellTypeBlanks)
      If Not objRng Is Nothing Then objRng.EntireRow.Delete
    End If
    Err.Clear
    On Error GoTo ErrorHandler
    
    'Begriffe löschen
    For lngIndex = 0 To UBound(varDelete)
      .UsedRange.Replace What:=varDelete(lngIndex), Replacement:="", LookAt:=xlPart, MatchCase:=False
    Next
    
    'Begriffe ersetzen
    For lngIndex = 0 To UBound(varReplace)
      .UsedRange.Replace What:=Split(varReplace(lngIndex), "|")(0), _
        Replacement:=Split(varReplace(lngIndex), "|")(1), LookAt:=xlPart, MatchCase:=False
    Next
    
    'Summenformel
    On Error Resume Next
    Set objRng = Nothing
    Set objRng = .Columns(7).SpecialCells(xlCellTypeConstants, xlNumbers)
    If Not objRng Is Nothing Then
      For Each objR In objRng
        If IsNumeric(objR.Offset(0, 1)) Then
          objR.Offset(0, -1) = objR & "+" & objR.Offset(0, 1)
        End If
      Next
    End If
    Err.Clear
    On Error GoTo ErrorHandler
  End With
Next

ErrorHandler:
With Application
  .EnableEvents = True
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
End With
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Zahlenbereiche, Suchen & Ersetzen in einem Sub

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zahlenbereiche, Suchen & Ersetzen in einem Sub

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread