Vba 下一步，如果，仅复制与输入匹配的数据

我已经十年没有写VBA了，也没有试着去看看我打破了什么。我编写了一个宏，它将数据从一张工作表复制到另一张工作表，一次复制一列，用于4个不同的列，并将其粘贴到下一个空闲单元格中。这个公式有效，但我想调整它，使其仅复制某些数据。下面是一个示例，我尝试仅在E中的日期值等于宏启动时输入的日期值时复制A。我很难平衡If/Then和For/Next。每次我放置结束If或Next时，都会收到错误

Dim DateValue As Variant
DateValue = InputBox("Enter the date to copy")

'copy and paste column A to column A if E = input date
For Each Cell In Worksheets("Enrichment Report").Range("E:E")
    If Cell.Value = DateValue Then
        Sheets("Enrichment Report").Select
        iMaxRow = 100
        For iCol = 1 To 1
            For iRow = 2 To iMaxRow
                With Worksheets ("Enrichment Report").Cells(iRow, iCol)
                    If .Value = "" Then
                        'empty row, do nothing
                    Else
                        .Copy
                        Sheets("Intake Form").Select
                        Range (A" & Rows.Count).End(xlUp).Offset(1).Select
                        Activesheet.Paste
                    End If
                End With
            Next
        End If
    Next iRow
Next iCol

---

显然，在CallumDA完成了适当的缩进后，应该按如下所示编写。在a范围内也有一个打字错误，应该是a范围：

---

我认为下面的代码会让你更容易理解

此外，它将更快地循环通过E列中的数据占用的单元格，而不是整个列

代码

您可以使用自动筛选并避免循环

另外，使用Application.InputBox方法而不是VBA InputBox函数来利用其类型参数并强制进行数字输入

Sub mmw()
    Dim targetSht As Worksheet
    Set targetSht = Sheets("Intake Form")

    Dim DateValue As Variant
    DateValue = Application.InputBox("Enter the date to copy", , , , , , , 2)


    With Worksheets("Enrichment Report") ' reference your "source" sheet
        With .Range("A1", .Cells(.Rows.Count, "E").End(xlUp)) ' reference its columns A:E cells from row 1 down to column E last not empty cell
            .AutoFilter Field:=1, Criteria1:="<>" 'filter on referenced range 1st column with not empty cells
            .AutoFilter Field:=5, Criteria1:=CStr(CDate(DateValue))

            If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then _
                .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy _
                Sheets("Intake Form").Cells(Sheets("Intake Form").Rows.Count, "A").End(xlUp).Offset(1)  '<--| if any cell filtered other than headers (which get always filtered) then copy filtered values to "paste" sheet

        End With
        .AutoFilterMode = False
    End With
End Sub

---

我用rubberduck工具缩进了你的代码。现在我们可以看到到底发生了什么！感谢您的回复，我确实收到了一个错误运行时438，在以下行中声明对象不支持此属性或方法：SheetsIntake Form.RangeA&Rows.Count.EndxlUp.Offset1.pastercorrection:感谢您的回复，我确实收到一个错误运行时438和修复偏移量1。粘贴到一个选择，然后下一行的activesheet.Paste解决了这个问题。但是，公式没有从A列复制相应的值。例如，E1不等于输入的日期，但当公式遇到E2等于输入的日期而不是粘贴A2时，粘贴A1。新的粘贴选项将删除所有错误消息，但是代码只是将所有的A复制到另一张纸上的A中，并不是基于E中的日期进行拉取。这比你做的更好！已成功将此样式应用于所有列。

Option Explicit

Sub Test()

Dim LastRow As Long, iMaxRow As Long, iCol As Long, iRow As Long
Dim DateValue As Variant
Dim Cell As Range

DateValue = InputBox("Enter the date to copy")

With Worksheets("Enrichment Report")
    ' get last row with data in column E
    LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row

    'copy and paste column A to column A if E = input date
    For Each Cell In .Range("E1:E" & LastRow)
        If Cell.Value = DateValue Then
            iMaxRow = 100
            For iCol = 1 To 1
                For iRow = 2 To iMaxRow
                    If .Cells(iRow, iCol).Value = "" Then
                        'empty row, do nothing
                    Else
                        .Cells(iRow, iCol).Copy
                        Sheets("Intake Form").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteAll                       
                    End If

                Next iRow
            Next iCol
        End If
    Next Cell
End With

End Sub

Sub mmw()
    Dim targetSht As Worksheet
    Set targetSht = Sheets("Intake Form")

    Dim DateValue As Variant
    DateValue = Application.InputBox("Enter the date to copy", , , , , , , 2)


    With Worksheets("Enrichment Report") ' reference your "source" sheet
        With .Range("A1", .Cells(.Rows.Count, "E").End(xlUp)) ' reference its columns A:E cells from row 1 down to column E last not empty cell
            .AutoFilter Field:=1, Criteria1:="<>" 'filter on referenced range 1st column with not empty cells
            .AutoFilter Field:=5, Criteria1:=CStr(CDate(DateValue))

            If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then _
                .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy _
                Sheets("Intake Form").Cells(Sheets("Intake Form").Rows.Count, "A").End(xlUp).Offset(1)  '<--| if any cell filtered other than headers (which get always filtered) then copy filtered values to "paste" sheet

        End With
        .AutoFilterMode = False
    End With
End Sub