Frage stellen

Tabelle nach variablen Werten durchsuchen und bestimmte Zellen verschieben/kopieren

1.5k Aufrufe
Gefragt in Tabellenkalkulation von
Hallo Experten,

ich möchte folgendes Makro erstellen:

In Zelle "B1" wird ein Wert eingeben (z.B. KW 17)
In Zelle "B2" wird ebenfalls ein Wert eingegeben (z.B. KW 16)

Nach betätigen eines Kommandoknopfes, soll das Tabellenblatt ("Datenblatt") nach der Zelle mit dem gleichen Inhalt wie Zelle "B1" durchsucht werden.
Ist die Zelle gefunden, soll selbiges Tabellenblatt nach der Zelle mit dem gleichen Zelleninhalt wie in "B2" durchsucht werden und anschließend der Zelleninhalt der Zelle über der ermittelten Zelle des Inhaltes von "B2" auf die Zelle über der Zelle des Inhaltes von "B1" verschoben werden.
Desweiteren soll der Zelleninhalt der Zelle unter der Zelle der ermittelten Zelle von "B2" auf die Zelle unter der ermittelten Zelle von "B1" kopiert werden.

Ich hoffe es ist einigermaßen verständlich beschrieben.
Leider reichen meine mangelhaften Makrokenntnisse nicht aus, um diese Herausforderung zu lösen. Ich hoffe ihr könnt mir weiterhelfen.

Gruß peydrr

6 Antworten

0 Punkte
Beantwortet von rainberg Profi (14.9k Punkte)
Hallo,


Leider reichen meine mangelhaften Makrokenntnisse nicht aus, um diese Herausforderung zu lösen


....das ist ja keine Schande, aber ich vermute, dass deine Kenntnisse dazu ausreichen, uns eine Beispielmappe zur Verfügung zu stellen, das würde uns einen Nachbau (zwecks Test) ersparen.

Gruß
Rainer
0 Punkte
Beantwortet von nighty Experte (6.6k Punkte)
hi peydrr ^^

ein beispiel :-)

suchbereiche anpassen

gruss nighty



Sub DeinMakro()
Dim Suche1 As Range, Suche2 As Range
Set Suche1 = Range("A3:D15").Find(Range("B1"))
Set Suche2 = Range("A3:D15").Find(Range("B2"))
If Not Suche1 Is Nothing And Not Suche2 Is Nothing Then
Rows(Suche2.Row - 1).Cut
Rows("1:1").Insert Shift:=xlDown
Rows(Suche2.Row + 1).Copy
Rows("3:3").Insert Shift:=xlDown
Application.CutCopyMode = False
Else
MsgBox ("Daten nicht gefunden")
End If
End Sub
0 Punkte
Beantwortet von
Hi all,

danke für die schnelle Antwort, aber es läuft noch nicht ganz so wie ich es mir dachte -.-

Dein Beispiel kopiert die kompletten Zeilen, ich möchte jedoch nur die jeweilgen Zelleninhalte unter und oberhalb der gefundenen Zelle verschieben und kopieren lassen.

Hier das umgeänderte Makro, so wie ich es mir vorstellen könnte:

Sub KW_suchen()

Dim Suche1 As Range
Dim Suche2 As Range
Set Suche1 = Range("A5:Y14").Find(Range("B1"))
Set Suche2 = Range("A5:Y14").Find(Range("B2"))

If Not Suche1 Is Nothing And Not Suche2 Is Nothing Then
Cells(Suche2.Cells - 1).Cut
Cells(Suche1.Cells - 1).Insert
Cells(Suche2.Cells + 1).Copy
Cells(Suche1.Cells + 1).Insert
Application.CutCopyMode = False
Else
MsgBox ("Daten nicht gefunden")
End If
End Sub

Leider erscheint die Fehlermeldung "Typen unverträglich". :(

Hier eine Beispielmappe:
www.file-upload.net/download-10647716/Test-Makro_Kw_suche.xlsx.html
(Farben nur zu Veranschaulichung)

Gruß peydrr
0 Punkte
Beantwortet von
Hi all,

nutze statt Cells(Suche2.Cells - 1).Cut lieber Suche2.offset(-1,0).CutFür die anderen Zeilen entsprechend.

Mr. K.
0 Punkte
Beantwortet von m-o Profi (22.9k Punkte)
Hallo,

versuch es mal so:

Sub KW_suchen()

Dim Suche1 As Range
Dim Suche2 As Range
Set Suche1 = Range("A5:Y14").Find(Range("B1"))
Set Suche2 = Range("A5:Y14").Find(Range("B2"))

If Not Suche1 Is Nothing And Not Suche2 Is Nothing Then
Cells(Suche1.Row - 1, Suche1.Column).Value = Cells(Suche2.Row - 1, Suche2.Column).Value
Cells(Suche2.Row - 1, Suche2.Column).ClearContents
Cells(Suche1.Row + 1, Suche1.Column).Value = Cells(Suche2.Row + 1, Suche2.Column).Value

Else
MsgBox ("Daten nicht gefunden")
End If
End Sub


Gruß

M.O.
0 Punkte
Beantwortet von
Hallo,

beide Ansätze funktionieren einwandfrei!
Sehr gut gelöst, vielen Dank und bis zum nächsten mal :)

Gruß peydrr
...