Copy entire row if CountA <>0 to another sheet

Harshil Mehta

New Member
Joined
May 14, 2020
Messages
19
Office Version
2013
Platform
Windows
I want to copy entire row if CountA <>0 for column J7:AM7 (headers on J6:AM6) and so on till the last used cell is column D and paste the entire row in sheet 1(A1) one below the another.

Sub copy_data()

Dim lr As Long
lr = Cells(Rows.Count, "D").End(xlUp).Row

If WorksheetFunction.Sheets(3).CountA(RANGE("J:AM" & lr)) <> 0 Then
EntireRow.Copy
Sheets(1).RANGE("a1").PasteSpecial Paste:=xlPasteValues

End If

End Sub




Please help me!
 

Some videos you may like

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.

BenMcBen

New Member
Joined
Aug 19, 2014
Messages
13
suggest you start by recording a macro to get your syntax a bit closer to whats actually gonna work then revert with a better example...
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
38,993
Office Version
365
Platform
Windows
How about
VBA Code:
Sub HarshilMehta()
   Dim Cl As Range
   
  For Each Cl In Range("J7:J" & Range("D" & Rows.Count).End(xlUp).Row)
      If Application.CountA(Cl.Resize(, 30)) > 0 Then
         Cl.EntireRow.Copy Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1)
      End If
   Next Cl
End Sub
 

Mentor82

Active Member
Joined
Dec 30, 2018
Messages
307
Hi,
Try this out. It should work, however I did not run it because I’m not home right now and I wrote it on a mobile.
Let me know if that works. If not, I’ll fix it.
VBA Code:
Sub ABC()
Dim LastRow&
Dim newRow&
Dim strRange$
LastRow= Sheets(3).Cells(Rows.Count, "d").End(xlUp).Row

newRow=1

For i = 7 To LastRow
    strRange =CStr ("J" & i & ":AM" & i)
    If WorksheetFunction.CountA(RANGE(strRange)) <> 0 Then
        newRow=newRow+1
        Sheets(3).Cells(i,1).EntireRow.Copy     Sheets(1).Cells(newRow,1)
    End If
Next

MsgBox "Done"

End Sub
 

Harshil Mehta

New Member
Joined
May 14, 2020
Messages
19
Office Version
2013
Platform
Windows
IT
Hi,
Try this out. It should work, however I did not run it because I’m not home right now and I wrote it on a mobile.
Let me know if that works. If not, I’ll fix it.
VBA Code:
Sub ABC()
Dim LastRow&
Dim newRow&
Dim strRange$
LastRow= Sheets(3).Cells(Rows.Count, "d").End(xlUp).Row

newRow=1

For i = 7 To LastRow
    strRange =CStr ("J" & i & ":AM" & i)
    If WorksheetFunction.CountA(RANGE(strRange)) <> 0 Then
        newRow=newRow+1
        Sheets(3).Cells(i,1).EntireRow.Copy     Sheets(1).Cells(newRow,1)
    End If
Next

MsgBox "Done"

End Sub
It worked perfectly, however it took nearly about 4-5 mins (no applications running in background) which i think should not happen if we are automating a task.
could you try to optimize the code as ill be adding few more lines to it?
 

Mentor82

Active Member
Joined
Dec 30, 2018
Messages
307
Hi,
Try this out now. It should run faster.

VBA Code:
Sub ABC()
Dim LastRow&
Dim newRow&
Dim strRange$
Dim c

On Error GoTo ErrorHandler

Application.ScreenUpdating = False
LastRow= Sheets(3).Cells(Rows.Count, "d").End(xlUp).Row

newRow=1

For i = 7 To LastRow
    strRange =CStr ("J" & i & ":AM" & i)
    For each c in range(strRange)
        If c.value <> "" then
            newRow=newRow+1
            Sheets(3).Cells(i,1).EntireRow.Copy     Sheets(1).Cells(newRow,1)
            Exit For
         End If
     Next c
Next

Application.ScreenUpdating = True

MsgBox "Done"

Exit sub

ErrorHandler:
Application.ScreenUpdating=True
MsgBox "Unexpected Error Occured!"


End Sub
 

Mentor82

Active Member
Joined
Dec 30, 2018
Messages
307
Hi,
I’m not sure it the second code I sent you would significantly run faster. It’s because it seems like you have loads of rows to copy and each row is copied one after another. There are two solutions which comes to my mind which may speed it up but there some restrictions to it:
1. I would need to sort the date in the main sheet to copy the rows, which match the conditions, at once. It might speed up.
2. Rewrite the code from the scratch using arrays and prepare all the data in arrays and then insert them in the worksheet. But in such case only values will be inserted without any formatting etc.
For both cases I’d need to know the column range of the data you have in the main worksheet from which the data is to be copied from.
What do you reckon?
 

Harshil Mehta

New Member
Joined
May 14, 2020
Messages
19
Office Version
2013
Platform
Windows
The early code ran more smoothly. How do I make a change in the code so that it copies only range A:AM in sheet3 till the last row in column D, instead of copying the entire row and paste it in Sheet1 one below the other? I think this will optimize the code even more.

Please help me out!
 

Harshil Mehta

New Member
Joined
May 14, 2020
Messages
19
Office Version
2013
Platform
Windows
Hi,
I’m not sure it the second code I sent you would significantly run faster. It’s because it seems like you have loads of rows to copy and each row is copied one after another. There are two solutions which comes to my mind which may speed it up but there some restrictions to it:
1. I would need to sort the date in the main sheet to copy the rows, which match the conditions, at once. It might speed up.
2. Rewrite the code from the scratch using arrays and prepare all the data in arrays and then insert them in the worksheet. But in such case only values will be inserted without any formatting etc.
For both cases I’d need to know the column range of the data you have in the main worksheet from which the data is to be copied from.
What do you reckon?
The early code ran more smoothly. How do I make a change in the code so that it copies only range A:AM in sheet3 till the last row in column D, instead of copying the entire row and paste it in Sheet1 one below the other? I think this will optimize the code even more.

Please help me out!
 

Mentor82

Active Member
Joined
Dec 30, 2018
Messages
307
Hi,
Here's a change I've done. Now the date is copied from sheet(3) range A:AM and paste to sheet(1) to column D on (horizontally),. Is that what you need or you want or data fom A:AM pasted in column D only?

VBA Code:
Sub ABC()
Dim LastRow&
Dim newRow&
Dim strRange$
LastRow= Sheets(3).Cells(Rows.Count, "d").End(xlUp).Row

newRow=1

For i = 7 To LastRow
    strRange =CStr ("J" & i & ":AM" & i)
    If WorksheetFunction.CountA(RANGE(strRange)) <> 0 Then
        newRow=newRow+1
        Sheets(3).Range(Cells(i,"A"),Cells(i,"AM")).Copy     Sheets(1).Cells(newRow,"D")
    End If
Next

MsgBox "Done"

End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,096,187
Messages
5,448,861
Members
405,535
Latest member
KLFT

This Week's Hot Topics

Top