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

使用您发布的第二个代码。我＆＃34;清洁＆＃34;稍微编写代码并修改代码以执行所需的任务。当您进行部分搜索（＆＃34; NOSH＆＃34;）时，请务必使用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

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

将符合特定条件的列复制到新工作表

1 个答案: