mehrere Bereiche markieren

Hallo zusammen,
ich möchte wiederkehrende Zellbereiche markieren, die den gleichen Suchbegriff enthalten,
um anschließend diese markierten Zellen mit einer Gültigkeit versehen zu können.
Dazu habe ich Range und Union benutzt. Das Problem ist, Union kann max. 30 Variablen. Ich benötige aber mindestens 50.
Meine Makros sehen so aus:


Sub Markierung1()
' 1 - 30
' Spalte Q - markieren von Bereichen für Weiterbearbeitung über alle markierten Zellen
Union(Range("Q11:S11"), Range("Q27:S27"), Range("Q43:S43"), Range("Q59:S59"), Range("Q75:S75"),  _
_
_
_
Range("Q91:S91"), Range("Q107:S107"), Range("Q123:S123"), _
Range("Q139:S139"), Range("Q155:S155"), Range("Q171:S171"), Range("Q187:S187"), Range("Q203: _
S203"), Range("Q219:S219"), Range("Q235:S235"), Range("Q251:S251"), _
Range("Q267:S267"), Range("Q283:S283"), Range("Q299:S299"), Range("Q315:S315"), Range("Q331: _
S331"), Range("Q347:S347"), Range("Q363:S363"), Range("Q379:S379"), _
Range("Q395:S395"), Range("Q411:S411"), Range("Q427:S427"), Range("Q443:S443"), Range("Q459: _
S459"), Range("Q475:S475")).Select
End Sub

und


Sub Markierung2()
' 31 - 50
Union(Range("Q491:S491"), Range("Q507:S507"), Range("Q523:S523"), Range("Q539:S539"), Range(" _
Q555:S555"), Range("Q571:S571"), Range("Q587:S587"), Range("Q603:S603"), _
Range("Q619:S619"), Range("Q635:S635"), Range("Q651:S651"), Range("Q667:S667"), Range("Q683: _
S683"), Range("Q699:S699"), Range("Q715:S715"), Range("Q731:S731"), _
Range("Q747:S747"), Range("Q763:S763"), Range("Q779:S779"), Range("Q795:S795")).Select
End Sub

Kann man diese beiden zusammenfassen? Idealerweise wär eine Abfrage nach dem Suchbegriff.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Peter:
ein Beispiel:

Option Explicit

Public Sub Beispiel()
    Dim objCell As Range, objRange As Range
    Dim strFirstAddress As String
    With Tabelle1.Columns(17)
        Set objCell = .Find(What:="Suchbegriff", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
        If Not objCell Is Nothing Then
            strFirstAddress = objCell.Address
            Set objRange = objCell
            Do
                Set objRange = Union(objRange, objCell)
                Set objCell = .FindNext(After:=objCell)
            Loop Until objCell.Address = strFirstAddress
            Set objCell = Nothing
        End If
    End With
    If Not objRange Is Nothing Then
        With objRange.Validation
            Call .Delete
            Call .Add(Type:=xlValidateList, Formula1:="1,2,3")
        End With
        Set objRange = Nothing
    End If
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread