loop through rows to copy range meeting criteria

Question

I have a workbook with a sheet (sheet2) containing 1600+ rows and 700+ columns.

Col A is name and Col B is counta of all columns from C to last col. It is always > 0.

The cell values of each column are like "29.11.17_124". Not all cells in these columns are filled. There are empty cells too. Each filled cell per col begins with the same date string.

I have a macro which asks for a date string. Then finds the col number where that string is. Suppose it is col 65. Then all rows from col A to col 65 are copied to sheet4. But in this sheet (sheet4), since the col B calculates new counta, I have to delete all rows where counta is < 1 as well.

Basically, I am copying 1600+ rows and then deleting 1000 rows (where counta is 0) in sheet4.

I want to modify my code so that only those rows whose counta is 1 and more are copied. The code to iterate through each row of sheet2 but also evaluate the new counta as derived from the col range.

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

Just a thought what could be easy to acomplish: Change counta-formula to countif and a date in some cell; filter your data with countif<>0; copy to new sheet — Jochen
In Sheet2 it is always > 0 but the sheet4 does have counta= 0 also beacuse the new derived range is smaller than the original one. These rows I am deleting later in the macro. — pradeep
Sheet2 counta is always > 0. counta in sheet4 when copied does have 0 also because the new column range is smaller than sheet2 range. These are later deleted in the macro. — pradeep

pradeep pradeep · Accepted Answer · 2017-12-07T05:35:45

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

loop through rows to copy range meeting criteria

1 Answers