Mehrer Zellen in verschiedenen Spalten auswählen

[Primo Centurio]

Hallo Zusammen ich habe folgendes Problem

Und zwar habe ich folgenden Code, der mir in der Tabelle alle Zellen mit dem Wert "402" sucht.

Code:

Private Sub CommandButton1_Click()
Dim c As Range, rng As Range, firstAddr As String

With ActiveSheet.UsedRange
Set c = .Find("402", lookat:=xlWhole)
If Not c Is Nothing Then
firstAddr = c.Address
Do
If Not rng Is Nothing Then
Set rng = Union(rng, c)
Else
Set rng = c
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddr
End If
End With
If Not rng Is Nothing Then rng.Select
End Sub

Nun möchte ich, dass er mir die Zellen 2 Spalten Links und die Zellen in 2 Spalten Rechts (Offset) auch auswählt.

Ich nehme an, dass hier der Code mit erweitert werden muss, jedoch komme ich auf keinen grünen Zweig

Code:

If Not rng Is Nothing Then rng.Select

kann mir jemand helfen? Im Anhang noch ein Bild von der Datei und Code 

Danke :)

LG Primo

[schauan]

Hallöchen,

im Prinzip z.B. was in der Art

rng.offset(0,-2).resize(,5)

[ralf_b]

PHP-Code:

private Sub CommandButton1_Click()
    Dim c As Range, rng As Range, firstAddr As String

    With ActiveSheet.UsedRange
        Set c = .Find("402", lookat:=xlWhole)
        If Not c Is Nothing Then
            firstAddr = c.Address
            Do
                If Not rng Is Nothing Then
                    Set c = Union(c, c.Offset(0, -2), c.Offset(0, 2))
                    Set rng = Union(rng, c)
                Else
                    Set rng = Union(c, c.Offset(0, -2), c.Offset(0, 2))
                End If
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddr
        End If
    End With
    If Not rng Is Nothing Then rng.Select
End Sub 


[Primo Centurio]

PHP-Code:

private Sub CommandButton1_Click()
    Dim c As Range, rng As Range, firstAddr As String

    With ActiveSheet.UsedRange
        Set c = .Find("402", lookat:=xlWhole)
        If Not c Is Nothing Then
            firstAddr = c.Address
            Do
                If Not rng Is Nothing Then
                    Set c = Union(c, c.Offset(0, -2), c.Offset(0, 2))
                    Set rng = Union(rng, c)
                Else
                    Set rng = Union(c, c.Offset(0, -2), c.Offset(0, 2))
                End If
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddr
        End If
    End With
    If Not rng Is Nothing Then rng.Select
End Sub 


Funktioniert perfekt :) Herzlichen Dank Ralf

[ralf_b]

OK freut mich, dann benutze bitte die Dankefunktion und markiere das Thema als erledigt.

[Primo Centurio]

Bedankt hatte ich mich sofort auch mit der Funktion ;)

Stemple ich als erledigt ab.