Copy columns which meet a specific criteria to a new sheet - vba

Question

im using this code and it works but somehow stops after the first row is copied. Do you have an idea why? Otherwise it seems to do what it should do, thanks! The searched term is nosh and in sheet 1 (Tabelle1) it is always found in this format D:XXX(NOSH) with XXX changing for different company names.
Public Sub Kopieren()
Dim WkSh_Q As Worksheet
Dim WkSh_Z As Worksheet
Dim rZelle As Range
Dim aUeberschr As Variant
Dim iIndx As Integer
Dim iSpalte As Integer
aUeberschr = Array("NOSH")
Application.ScreenUpdating = False
Set WkSh_Q = Worksheets("Tabelle1") ' das Quell-Tabellenblatt
Set WkSh_Z = Worksheets("Tabelle2") ' das Ziel-Tabellenblatt
With WkSh_Q.Rows
For iIndx = 0 To UBound(aUeberschr)
Set rZelle = .Find(aUeberschr(iIndx), LookAt:=xlWhole, LookIn:=xlValues)
If Not rZelle Is Nothing Then
iSpalte = iSpalte + 1
WkSh_Q.Columns(rZelle.Column).Copy Destination:=WkSh_Z.Columns(iSpalte)
End If
Next iIndx
End With
Application.ScreenUpdating = True
End Sub
Edit:
And I would need to copy every coloumn with NOSH to be copied to "Tabelle2"
I found this Code to search the whole first sheet and repeat the task but it seems to copy just the names of the stocks (BAYER etc) to every row.
Private Sub CommandButton1_Click()
Dim WkSh_Q As Worksheet, WkSh_Z As Worksheet
Dim rZelle As Range, aUeberschr As Variant
Dim strErste As String
Dim iIndx As Long, iSpalte As Long
aUeberschr = Array(NOSH)
Application.ScreenUpdating = False
Set WkSh_Q = Worksheets("Tabelle1") ' das Quell-Tabellenblatt
Set WkSh_Z = Worksheets("Tabelle2") ' das Ziel-Tabellenblatt
With WkSh_Q.Cells
For iIndx = 0 To UBound(aUeberschr)
Set rZelle = .Find(aUeberschr(iIndx), LookAt:=xlWhole, LookIn:=xlValues)
If Not rZelle Is Nothing Then
strErste = rZelle.Address
Do
iZeile = iZeile + 1
WkSh_Q.Rows(rZelle.Row).Copy Destination:=WkSh_Z.Rows(iZeile)
Set rZelle = .FindNext(rZelle)
Loop Until strErste = rZelle.Address
End If
Next iIndx
End With
Application.ScreenUpdating = True
End Sub

Answer 1

Using the second code you posted. I "cleaned" up the code a bit and also modified the code to do your desired task. When you are doing a partial search ("NOSH") make sure to use LookAt:=xlPart instead of LookAt:=xlWhole. Also in your case, if you want to copy the columns use WkSh_Q.Columns(rZelle.Column).Copy Destination:=WkSh_Z.Columns(iZeile) instead of WkSh_Q.Rows(rZelle.Row).Copy Destination:=WkSh_Z.Rows(iZeile)
Dim WkSh_Q As Worksheet, WkSh_Z As Worksheet
Dim rZelle As Range, aUeberschr As String
Dim strErste As String
Dim iZeile As Integer
aUeberschr = "NOSH"
Set WkSh_Q = Worksheets("Tabelle1") ' das Quell-Tabellenblatt
Set WkSh_Z = Worksheets("Tabelle2") ' das Ziel-Tabellenblatt
With WkSh_Q.Cells
Set rZelle = .Find(aUeberschr, LookAt:=xlPart, LookIn:=xlValues)
If Not rZelle Is Nothing Then
strErste = rZelle.Address
Do
iZeile = iZeile + 1
WkSh_Q.Columns(rZelle.Column).Copy Destination:=WkSh_Z.Columns(iZeile)
Set rZelle = .FindNext(rZelle)
Loop Until strErste = rZelle.Address
End If
End With
Hope that helps, good luck.