Excel VBA Wert in Zeile 1 Suchen und Spalte rechts einfügen

Moin,

ich benötige mal wieder eure Excel-VBA-Kenntnisse.

Folgendes Problem:
Ich möchte mittels VBA einen Wert suchen, der immer in Zeile 1 steht. Wenn dieser gefunden wird, dann soll diese Spalte kopiert und zweimal rechts eingefügt werden.

Ausgangslage:

Ich suche nach dem Wert Katze

Hund	Katze	Maus
wau	miau	piep

Wie es aussehen sollte:

Hund	Katze	Katze	Katze	Maus
wau	miau	miau	miau	piep

Ich habe schon versucht es aufzuzeichnen und dann zu verallgemeinern, aber das hat leider nicht funktioniert.

Danke für Eure Hilfe!

Kalisser

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 365559

Url: https://administrator.de/contentid/365559

Ausgedruckt am: 24.11.2024 um 20:11 Uhr

5 Kommentare

Neuester Kommentar

Hi,

Ich habe schon versucht es aufzuzeichnen und dann zu verallgemeinern, aber das hat leider nicht funktioniert.

Zeige uns doch mal, was Du schon hast.

E.

Servus @Kalisser,
guckst du

Sub FindAndCopy()
    'Variablen  
    Dim strSearch As String, c As Range, i as integer
    'Suchwort  
    strSearch = "Katze"  
    ' In der Zeile 1 suchen  
    With ActiveSheet.Range("1:1")  
        ' suche nach Suchwort im "ganzen", kompletter Wert muss übereinstimmen (xlPart oder Wildcards ändern das Verhalten)  
        Set c = .Find(strSearch, LookIn:=xlValues, LookAt:=xlWhole)
        ' Wenn Suchwort gefunden wurde ...  
        If Not c Is Nothing Then
            ' Kopiere die Spalte 2 mal rechts von der Spalte  
            For i = 1 To 2    
                c.EntireColumn.Copy
                c.Insert xlShiftToLeft
            Next
        End If
    End With
    'CutCopy Mode deaktivieren  
    Application.CutCopyMode = False
End Sub

Grüße Uwe

Hallo Uwe,

vielen Dank. Das klappt schon mal wunderbar.
Das Problem, was ich gerade noch festgestellt habe, ist, dass ich "Katze" mehrfach in der ersten Zeile stehen habe. Die Duplizierung funktioniert nur für den ersten Treffer.

Ich hoffe, ich kriege das selber gefixt. Könnte ja eine While-Schleife drum packen (hoffe ich :D)

Danke schon einmal für deine Hilfe.

@edit: Ich habe gerade noch mal überlegt. Durch das Duplizieren steht ja immer Katze oben und wird gefunden. Das endet dann ja in einer Endlosschleife.

@edit2: Ich benenne die oberste Zeile davor einfach in "Katz" mit "c.Value = "Katz" um

VG
Kalisser

So hat es jetzt funktioniert. Noch einmal 1000 Dank an Uwe.

Sub FindAndCopy()

    'Variablen  
    Dim strSearch As String, c As Range, i As Integer
    'Suchwort  
    strSearch = "Katze"  
    ' In der Zeile 1 suchen  
    With ActiveSheet.Range("1:1")  
        ' suche nach Suchwort im "ganzen", kompletter Wert muss übereinstimmen (xlPart oder Wildcards ändern das Verhalten)  
        Set c = .Find(strSearch, LookIn:=xlValues, LookAt:=xlWhole)
        ' Wenn Suchwort gefunden wurde ...  
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                ' Kopiere die Spalte 2 mal rechts von der Spalte  
                For i = 1 To 2
                    c.Value = "Katz"  
                    c.EntireColumn.Copy
                    c.Insert xlShiftToLeft
                Next
                    
                Set c = .FindNext(c)
                If c Is Nothing Then
                    GoTo DoneFinding
                End If
                Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
DoneFinding:
    End With
    'CutCopy Mode deaktivieren  
    Application.CutCopyMode = False
End Sub

Zitat von @Kalisser:
@edit: Ich habe gerade noch mal überlegt. Durch das Duplizieren steht ja immer Katze oben und wird gefunden. Das endet dann ja in einer Endlosschleife.

Nein das endet in keiner Schleife, denn der Range c wird beim Einfügen der verdoppelten Spalten 2 Spalten nach Rechts verschoben und die fortgesetzte Suche wir immer eine Zelle hinter der aktuellen weitergeführt.

@edit2: Ich benenne die oberste Zeile davor einfach in "Katz" mit "c.Value = "Katz" um

Du musst deshalb auch auch nicht den Inhalt der Zelle ändern:
Also ergibt folgender Code das gewünschte ohne den Zellinhalt der kopierten Spalten ändern zu müssen.

Sub FindAndCopy()
    'Variablen  
    Dim strSearch As String, c As Range, i As Integer
    'Suchwort  
    strSearch = "Katze"  
    ' In der Zeile 1 suchen  
    With ActiveSheet.Range("1:1")  
        ' suche nach Suchwort im "ganzen", kompletter Wert muss übereinstimmen (xlPart oder Wildcards ändern das Verhalten)  
        Set c = .Find(strSearch, LookIn:=xlValues, LookAt:=xlWhole)
        ' Wenn Suchwort gefunden wurde ...  
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                ' Kopiere die Spalte 2 mal rechts von der Spalte  
                For i = 1 To 2
                    c.EntireColumn.Copy
                    c.Insert xlShiftToLeft
                Next
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With
    'CutCopy Mode deaktivieren  
    Application.CutCopyMode = False
End Sub

Grüße Uwe