Vba 循环行以复制符合条件的范围

我有一个工作簿，它的工作表2包含1600多行和700多列

列A是名称，列B是从C到最后一列的所有列的计数A。它总是>0

每列的单元格值类似于29.11.17_124。并非这些列中的所有单元格都已填充。也有空的牢房。每个列的每个填充单元格都以相同的日期字符串开头

我有一个宏，它要求输入一个日期字符串。然后查找该字符串所在的列编号。假设它是第65列。然后将A列到65列的所有行复制到图纸4。但是在这张表4中，由于列B计算新的counta，我必须删除counta小于1的所有行

基本上，我复制了1600多行，然后删除了表单4中counta为0的1000行

我想修改代码，以便只复制counta为1或更多的行。代码将遍历sheet2的每一行，但也将计算从col范围派生的新counta

Sub dcopyrange()
Dim rng1 As Range
Dim sh1 As Worksheet, sh2 As Worksheet
Dim fc As Integer
Dim lc As Integer
Dim valuee1 As Variant
Dim lRow As Long
Dim lRow2 As Long
Dim iCntr As Long
Sheet4.Cells.Clear
sheet2.Select
lRow2 = sheet2.Cells(Rows.Count, "A").End(xlUp).Row

Set sh1 = Sheets("Sheet2")
 Set sh2 = Sheets("Sheet4")

valuee1 = InputBox("enter date dd-m-yy", "Report by department")
Set rng1 = sh1.UsedRange.Find(valuee1, , xlValues, xlPart)
If Not rng1 Is Nothing Then



MsgBox "Found in column " & rng1.Column

fc = 1
lc = (fc + rng1.Column) - 1


 Range(Columns(fc), Columns(lc)).copy sh2.Range("A1")

Else
MsgBox "Not found", vbCritical
End If
ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add Key:=Range("b1:b2500" _
        ), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet4").Sort
        .SetRange Range("A1:ZZ2500")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


    Sheet4.Activate

    lRow = Sheet4.Cells(Rows.Count, "A").End(xlUp).Row

    For iCntr = lRow To 1 Step -1

    If Cells(iCntr, 2).Value = 0 Then Cells(iCntr, 2).EntireRow.Clear


    Next iCntr
End Sub

---

只是一个简单的想法：将counta公式更改为countif，并在某个单元格中指定日期；使用countif0过滤数据；复制到新的图纸，因此counta并不总是>0？在图纸2中，counta总是>0，但图纸4也有counta=0，因为新的衍生范围小于原始范围。我稍后将在宏中删除这些行。Sheet2 counta始终>0。复制时，sheet4中的counta也有0，因为新列范围小于sheet2范围。这些将稍后在宏中删除。

Sub filtercopyrange()

Dim rng1 As Range
Dim sh1 As Worksheet, sh2 As Worksheet
Dim fcol As Integer
Dim lcol As Integer
Dim valuee1 As Variant
Dim lRow2 As Long
Dim lRow1 As Long
Dim iCntr As Long
Dim i As Integer
Dim ct As Variant

Sheet7.Cells.Clear
Sheet2.Select

Set sh1 = Sheets("Sheet2")
 Set sh2 = Sheets("Sheet7")

valuee1 = InputBox("enter date dd-mm-yyyy", "Column Range")
Set rng1 = sh1.UsedRange.Find(valuee1, , xlValues, xlPart)
If Not rng1 Is Nothing Then
MsgBox "Found in column " & rng1.Column
fcol = 1
lcol = (fcol + rng1.Column) - 1
Else
MsgBox "Not found", vbCritical
End If

lRow2 = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row


For i = 1 To lRow2
With sh1

        ct = Application.WorksheetFunction.CountA(Range(Cells(i, 3), Cells(i, lcol)))
        If ct > 0 Then
         Sheet2.Range(Cells(i, 1), Cells(i, lcol)).Copy 

        Sheet7.Range("a" & Rows.Count).End(xlUp).Offset(1,0).PasteSpecial

        Else
        End If

End With
        Next
Sheet7.Activate
lRow1 = Sheet7.Cells(Rows.Count, "A").End(xlUp).Row

Range("A1:bz" & lRow1).Sort key1:=Range("B1:B" & lRow1), _
   order1:=xlDescending, Header:=xlNo
End Sub