loop through rows to copy range meeting criteria - vba

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

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