Question

自从我写完VBA并试图伸手去看看我打破了什么以来已经十年了。我写了一个宏，它将数据从一个工作表复制到另一个工作表，一次一列，用于4个不同的列，并将其粘贴到下一个空白单元格中。这个公式有效，但我想调整它只复制某些数据。下面是一个例子，如果E中的日期值等于宏开始时输入的输入日期值，我试图只复制A.我在平衡If/Then和For/Next方面遇到的问题非常困难。每次发出End 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

Answer 1

我认为以下代码将更容易您遵循

此外，使用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

Answer 2

显然，通过CallumDA进行适当的缩进，应该写成如下。此外，Range (A"中也有拼写错误，应为Range ("A"：

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 iRow
        Next iCol
    End If
Next

Answer 3

您可以使用AutoFilter()并避免循环

另外，使用Application.InputBox()方法代替VBA InputBox()函数来利用其Type参数并强制输入数字

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

接下来，如果，并且仅复制与输入

3 个答案: