Question

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

以下是我最近的尝试，但由于我假设的各种原因不起作用，但这是我提出的最佳尝试

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

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

Answer 2

避免使用选择和选择。复制，它会给你带来很多麻烦，只需在开始使用范围之前声明所有内容并使用Range Class方法复制/粘贴到之前声明的另一个工作表，所以没有需要移动“围绕工作表”来复制和粘贴就像人类一样。让我们开始思考计算机，他已经记住了他需要处理的所有事情，所以使用它！

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

以下是您案例中的示例：

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

Answer 3

这是另一种可能对您更有效的解决方案：

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的新工作表，代码字就会很好并且也会转移这一行。}

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

3 个答案: