如果列D包含某些文本，则从主列表中复制行

Question

对VBA来说很新，所以我可以使用这个帮助，因为我一直在整个早上都在努力。我有一个主列表，在D列中有“1x Daily”和“1x Month”等词。我的目标是，无论它在那一栏中说了什么，它都会放在相应的新表中。所以在这种情况下，如果D2 =“每日一次”，那么整个行被复制到名为“每日一次”的工作表中

下面是我最近的尝试，但由于各种原因，它的最好的尝试，我想出了

Sub Test() 
    For Each Cell In Sheet(1).Range("D:D") 
    If Cell.Value = "1x Daily AM" Then 
     matchRow = Cell.Row 
     Rows(matchRow & ":" & matchRow).Select 
     Selection.Copy 

     Sheets("1x Daily All").Select 
     ActiveSheet.Rows(matchRow).Select 
     ActiveSheet.Paste 
     Sheets("Master Vitals Data").Select 
    End If 
    Next 
End Sub 

编辑，当我在编辑器中，并尝试运行的代码，我得到错误信息“编译子故障。或函数未定义”

Answer 1

这里是另一种解决方案可能连工作更好地为您：

Option Base 0 
Option Explicit 
Option Compare Text 

Sub TestRevised() 

Dim cell As Range 
Dim cmt As Comment 
Dim bolFound As Boolean 
Dim sheetNames() As String 
Dim lngItem As Long, lngLastRow As Long 
Dim sht As Worksheet, shtMaster As Worksheet 

'Set master sheet 
Set shtMaster = ThisWorkbook.Worksheets("Master Vitals Data") 

'Get the names for all other sheets 
ReDim sheetNames(0) 
For Each sht In ThisWorkbook.Worksheets 
    If sht.Name <> shtMaster.Name Then 
     sheetNames(UBound(sheetNames)) = sht.Name 
     ReDim Preserve sheetNames(UBound(sheetNames) + 1) 
    End If 
Next sht 
ReDim Preserve sheetNames(UBound(sheetNames) - 1) 

For Each cell In shtMaster.Range("D1:D" & shtMaster.Cells(shtMaster.Rows.Count, "D").End(xlUp).Row) 
    bolFound = False 
    For lngItem = LBound(sheetNames) To UBound(sheetNames) 
     If cell.Value2 = sheetNames(lngItem) Then 
      bolFound = True 
      Set sht = ThisWorkbook.Worksheets(sheetNames(lngItem)) 
      On Error GoTo SetFirst 
      lngLastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1 
      On Error GoTo 0 
      shtMaster.Rows(cell.Row).EntireRow.Copy Destination:=sht.Cells(lngLastRow, 1) 
     End If 
    Next lngItem 
    If bolFound = False Then 
     For Each cmt In shtMaster.Comments 
      If cmt.Parent.Address = cell.Address Then cmt.Delete 
     Next cmt 
     cell.AddComment "no sheet found for this row" 
    End If 
Next 

Exit Sub 

SetFirst: 
    lngLastRow = 1 
    Resume Next 

End Sub 

从本质上讲，这个代码第一收集Excel文件中的所有工作表名称，然后将它们与每行的D列中的单元格内容进行比较。如果存在的表单，那么写入列D的任何内容都将复制该行。像这样，你不仅可以有每月或每周的工作表。而且还包括每日或每两周或每年的工作表。此外，这段代码会在没有找到合适的工作表时找不到的行添加注释。像这样，你可以立即看到一张纸的拼写是否关闭。

以下截屏是代码的短示范：

_{注意，片材的主片材（包含所有要传输的数据）必须以在给定的名称一致码。否则，VBA不知道从哪里传输数据。另请注意，带sheet6的行首先不会被传输，因为没有表单。但是，一旦我创建了名为sheet6的新工作表，代码字就可以正常工作，并且可以传递此行。}

Answer 2

的你的代码只有一个明显的问题，就是粘贴后你并没有移动选择。在目标工作表中，您应该在粘贴一个后移动到下一行。否则，每个新的粘贴操作都会覆盖以前的粘贴。

Answer 3

避免使用选择和选择。复制它会带来很多麻烦，只需在开始使用范围进行操作之前声明所有内容，并使用Range Class方法复制/粘贴到先前声明的另一个工作表，不需要像“人物”那样移动“表单”来复制和粘贴。让我们开始考虑作为电脑，他已经记得他需要处理的一切，所以使用它！

我建议你在开始在VBA中编写代码之前声明每个对象，这样你就可以获得该对象的属性和方法（使用intellisense，只需在对象名称和VBA之后做一点就可以显示出你需要的所有东西），例如。 Range对象具有一个“COPY”方法，其中有一个DESTINATION参数也可以用来将范围从一个点移动到另一个点。

这里是你的情况的例子：

Option Explicit 

Sub test2() 
    'SPECIFY OPTION EXPLICIT TO DON'T MISS ANY DECLARATION 
    Dim ws_Master As Worksheet 'Master Worksheet 
    Dim rng As Range 'range to iterate 
    Dim cell As Range 'cell for iteration 
    Dim ws_1xDaily As Worksheet 'Worksheet for daily data 
    Dim ws_1xMonthly As Worksheet 'Worksheet for monthly data 

    Dim i As Integer, j As Integer 'Integer for parsing 
    'END DECLARATION 

    'Sheets and range object creation 

    Set ws_Master = ThisWorkbook.Sheets("Master Vitals Data") 
    Set rng = ws_Master.Range("D1:D" & ws_Master.Range("D" & Rows.Count).End(xlUp).Row) 'This will get the last row of the Range D:D so we can iterate until last row 
    Set ws_1xDaily = ThisWorkbook.Sheets("1x Daily All") 
    Set ws_1xMonthly = ThisWorkbook.Sheets("1x Monthly All") 

    'End 

    'That's all you have to do now is just copy a range to another range, just few line of code in a for each loop: 

    i = 1 'to remember the last row we used in the daily sheet 
    j = 1 'same as before but for the monthly sheet 
    For Each cell In rng 
     If cell.Value = "1x Daily AM" Then cell.EntireRow.Copy Destination:=ws_1xDaily.Range("A" & i): i = i + 1 
     If cell.Value = "1x Monthly" Then cell.EntireRow.Copy Destination:=ws_1xMonthly.Range("A" & j): j = j + 1 
    Next cell 

    'End 

End Sub 

如果你不会更有效率，你可以使用Range对象的.Find方法找到每一个细胞都包含您正在搜索什么，在“D：D”范围，没有指定最后一行，也没有迭代空单元格，请查看该方法！

这是日常活动，与.Find方法的例子：

Sub test2() 
    'SPECIFY OPTION EXPLICIT TO DON'T MISS ANY DECLARATION 
    Dim ws_Master As Worksheet 'Master Worksheet 
    Dim rng As Range 'range to iterate 
    Dim cell As Range 'cell for iteration 
    Dim ws_1xDaily As Worksheet 'Worksheet for daily data 
    Dim ws_1xMonthly As Worksheet 'Worksheet for monthly data 
    Dim firstAddress As String 
    Dim toCopyRng As Range 
    'END DECLARATION 

    'Sheets and range object creation 

    Set ws_Master = ThisWorkbook.Sheets("Master Vitals Data") 
    Set rng = ws_Master.Range("D:D") 
    Set ws_1xDaily = ThisWorkbook.Sheets("1x Daily All") 
    Set ws_1xMonthly = ThisWorkbook.Sheets("1x Monthly All") 

    i = 1 'to remember the last row we used in the daily sheet 
    Set toCopyRng = rng.Find("1x Daily AM", LookIn:=xlValues) 
    If Not toCopyRng Is Nothing Then 
     firstAddress = toCopyRng.Address 
     Do 
      toCopyRng.EntireRow.Copy Destination:=ws_1xDaily.Range("A" & i): i = i + 1 'copy and increment row of the daily sheet 
      Set toCopyRng = rng.FindNext(toCopyRng) 
     Loop While Not toCopyRng Is Nothing And toCopyRng.Address <> firstAddress 
    End If 

End Sub