Question

我有一张包含1600多行和700多列的工作表（sheet2）。

Col A是名称，Col B是从C到最后一列的所有列的counta。它始终是> 0

每列的单元格值类似于“29.11.17_124”。并非所有列中的单元格都已填充。还有空单元格。每个col的每个填充单元格都以相同的日期字符串开头。

我有一个要求日期字符串的宏。然后找到该字符串所在的列号。假设它是col 65.然后从col A到col 65的所有行都被复制到sheet4。但是在这张表（sheet4）中，由于col B计算新的counta，我必须删除counta所在的所有行＆lt; 1也是。

基本上，我正在复制1600多行，然后在sheet4中删除1000行（其中counta为0）。

我想修改我的代码，以便只复制那些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

Answer 1

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

循环遍历行以复制范围会议标准

1 个答案: