Excel bei Zelleninhalt ganze Spalte kopieren

Computer: Software & Programmierung Visual Basic
#1

Hallo zusammen,

benötige folgende Lösung:

In einer Tabelle stehen in unterschiedlichen Zellen die gleichen Inhalte. Wenn nun dieser Inhalt gefunden wird, soll die komplette Spalte kopiert werden und in ein extra Blatt eigefügt werden. Suchfunktion startet sooft wie der Wert in der Tabelle enthalten ist.

Hoffe es versteht jemand was ich will :wink:)

Jedefalls vielen Dank im voraus

Euer Dr. Sandor

#2

In einer Tabelle stehen in unterschiedlichen Zellen die
gleichen Inhalte. Wenn nun dieser Inhalt gefunden wird, soll
die komplette Spalte kopiert werden und in ein extra Blatt
eigefügt werden. Suchfunktion startet sooft wie der Wert in
der Tabelle enthalten ist.

Hallo Sandor,

Alt+F11, Einfügen Modul, Code reinkopieren, VB-Editor schließen.
Makro mit Alt+F8… ausführen.

Gruß
Reinhard

Sub tt()
Dim c, firstaddress, wks1 As Worksheet, wks2 As Worksheet, Spa As Long
Set wks1 = Worksheets("Tabelle1")
Set wks2 = Worksheets("Tabelle2")
With wks1.UsedRange 
 Set c = .Find("xyz", LookIn:=xlValues)
 If Not c Is Nothing Then
 firstaddress = c.Address
 Do
 Spa = Spa + 1
 c.EntireColumn.Copy Destination:=wks2.Cells(1, Spa)
 Set c = .FindNext(c)
 Loop While Not c Is Nothing And c.Address firstaddress
 End If
End With
End Sub
#3

Hallo Reinhard,

  1. vielen Dank für deine Hilfe.

Nur es funzt nich.

Hier ein kleines Beispiel:

Spalte a Spalte b Spalte c Spalte d
1 a b c
2 z t x
3 w 3 y
4 7 d z
5 9 j k
Bei Suche „Z“ Ergebniss:
2 z t x
4 7 d z

Ich hoffe, jetzt ist klar was ich benötige.

Thx to all

Grüsse Dr.Sandor

#4

Spalte a Spalte b Spalte c Spalte d
1 a b c
2 z t x
3 w 3 y
4 7 d z
5 9 j k
Bei Suche „Z“ Ergebniss:
2 z t x
4 7 d z

Ich hoffe, jetzt ist klar was ich benötige.

Hallo Dr.,

Scherzkeks :smile:

In deiner Anfrage stand „…soll die komplette Spalte kopiert werden…“
Was du willst ist „…soll die komplette Zeile kopiert werden…“

Minimalstrafe für so einen Fauxpaux ist wie im Film aller Filme, zieh dich selbst am Ohr, schnapp dir Kreide und gehe runter und schreibe an die Häuserwände 100mal „Ich soll nicht Spalte sagen wenn ich zeile meine“, natürlich auf Lateinisch :smile:

Nachfolgend der neue Code.
Achja, wenn du Einrückungen in Tabellen, Codes erhalten willst wenn du sie hier zeigst, benutze den Pre-Tag, wird unterhalb des Eingabefensters erläutert.

Gruß
Reinhard

Option Explicit

Sub tt()
Dim c, firstaddress, wks1 As Worksheet, wks2 As Worksheet, Zei As Long
Set wks1 = Worksheets("Tabelle1")
Set wks2 = Worksheets("Tabelle2")
With wks1.UsedRange
 Set c = .Find("xyz", LookIn:=xlValues)
 If Not c Is Nothing Then
 firstaddress = c.Address
 Do
 Zei = Zei + 1
 c.EntireColumn.Copy Destination:=wks2.Cells(Zei, 1)
 Set c = .FindNext(c)
 Loop While Not c Is Nothing And c.Address firstaddress
 End If
End With
End Sub
#5

Hallo Dr.,

sorry, war noch ein Fehler im Code, nimm bitte diesen.

Gruß
Reinhard

Option Explicit

Sub tt()
Dim c, firstaddress, wks1 As Worksheet, wks2 As Worksheet, Zei As Long
Set wks1 = Worksheets("Tabelle1")
Set wks2 = Worksheets("Tabelle2")
With wks1.UsedRange
 Set c = .Find("xyz", LookIn:=xlValues)
 If Not c Is Nothing Then
 firstaddress = c.Address
 Do
 Zei = Zei + 1
 c.EntireRow.Copy Destination:=wks2.Cells(Zei, 1)
 Set c = .FindNext(c)
 Loop While Not c Is Nothing And c.Address firstaddress
 End If
End With
End Sub