Keine ganzen Zeilen sondern nur den Bereich kopieren

Hallo zusammen,

Kann mir jemand sagen, wie ich bei diesem Code nicht die ganze Zeile (1) , sondern nur den Bereich von A bis G der jeweiligen Zeilen nach Tabelle2 kopieren kann (siehe Bild1)???


Sub kopieren_Daten()
Dim WkSh_Q As Worksheet
Dim WkSh_Z As Worksheet
Dim rZelle As Range
Dim sFundst As String
Dim sSuchbegriff As String
Dim lZeile_Z As Long
sSuchbegriff = "K-E*" ' der zu suchende Begriff
lZeile_Z = 2 ' die erste Ausgabezeile -1
Set WkSh_Q = Worksheets("Tabelle1") 'Quell-Tabellenblatt in Basis-Datei
Set WkSh_Z = Worksheets("Tabelle2") 'Ziel-Tabellenblatt in Stamm Datei
'Kopiervorgang starten
With WkSh_Q.Columns(1) 'Auswahl Spalte A (1=A)
Set rZelle = .Find(sSuchbegriff, LookAt:=xlWhole, LookIn:=xlValues)
If Not rZelle Is Nothing Then
sFundst = rZelle.Address
Do
lZeile_Z = lZeile_Z + 1

(1) WkSh_Q.Rows(rZelle.Row).Copy Destination:=WkSh_Z.Rows(lZeile_Z)

Set rZelle = .FindNext(rZelle)
Loop While Not rZelle Is Nothing And rZelle.Address <> sFundst
Else
End If
End With
'Kopiervorgang beenden
End Sub

Bild1


Und evtl. ein Hinweis, dass nur die jeweiligen Zellen A, C, E und G bei dem Begriff "K-E" in Tabelle2 kopiert werden (siehe Bild2).

Bild2



Vielen Dank im Voraus . . .

WkSh_Q.Range(Cells(rZelle.Row, "A"), Cells(rZelle.Row, "G")).Copy Destination:=WkSh_Z.Cells(lZeile_Z, "A")

WkSh_Q.Cells(rZelle.Row, "C").Copy Destination:=WkSh_Z.Cells(lZeile_Z, "B")

With rZelle
    Union(.Cells(.Row, "A"), .Cells(.Row, "C"), .Cells(.Row, "E"), .Cells(.Row, "G")).Copy WkSh_Z.Cells(lZeile_Z, "A")  
   'oder  
    Union(.Offset(0, 0), .Offset(0, 2), .Offset(0, 4), .Offset(0, 6)).Copy WkSh_Z.Cells(lZeile_Z, "A")  
End With

With rZelle.Rows
    Union(.Columns("A"), .Columns("C"), .Columns("E"), .Columns("G")).Copy WkSh_Z.Cells(lZeile_Z, "A")   
End With