將滿足特定條件的列複製到新工作表

Question

即時通訊使用此代碼，它可以工作但在第一行復制後以某種方式停止。你知道爲什麼嗎？否則，它似乎做它應該做的，謝謝！搜索的詞是nosh，在表1（Tabelle1）中總是以這種格式存在D：XXX（NOSH），其中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 

編輯：

而且我需要每一個coloumn與NOSH複製到被複制到「Tabelle2」

我發現這個代碼搜索整個第一板和重複任務，但它似乎只是將股票的名稱（BAYER等）複製到每一行。

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

使用您發佈的第二個代碼。我「清理了」了一下代碼，並修改了代碼以完成您所期望的任務。當您進行部分搜索時（「NOSH」），請務必使用LookAt:=xlPart而不是LookAt:=xlWhole。

另外，在你的情況，如果你要複製的列使用WkSh_Q.Columns(rZelle.Column).Copy Destination:=WkSh_Z.Columns(iZeile)代替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 

希望幫助，祝你好運。