Vba 将满足特定条件的列复制到新图纸

我正在使用这段代码，它可以工作，但在复制第一行后不知何故会停止。你知道为什么吗？否则它似乎做了它应该做的，谢谢！搜索的术语是nosh，在表1的表1中，它总是以D:XXXNOSH格式出现，XXX因不同的公司名称而改变

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

编辑：

我需要把每一个结肠和小食复制到Tabelle2

我找到了这个代码来搜索整个第一页并重复这个任务，但它似乎只是将拜耳等股票的名称复制到每一行

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

---

使用您发布的第二个代码。我稍微整理了一下代码，还修改了代码以完成您想要的任务。进行部分搜索时，请确保使用LookAt:=xlPart而不是LookAt:=xlother。同样在您的情况下，如果要复制列，请使用WkSh_Q.ColumnsrZelle.Column.copy Destination:=WkSh_Z.ColumnsiZeile，而不是WkSh_Q.RowsrZelle.Row.copy Destination:=WkSh_Z.RowsiZeile

---

希望这有帮助，祝你好运。

你能在表格1中发布你的数据的截图，并在表格2中发布你想要的结果吗？它只在第一行显示WkSh_Q.Rows1截图：这是我无法在上面发布的截图，因为我需要10个声誉。是的，1是错误的，所以我更改了它，剩下的问题是a为什么第二个代码只复制每个列的第一行，并用它们填充sheet2中的列和/或b如何更新第一个代码，使其继续复制第二行中包含NOSH一词的每个列。我感谢你的任何想法！很高兴我能帮忙。祝你节日快乐=

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