Copy entire row if CountA <>0 to another sheet

Harshil Mehta

Board Regular
Joined
May 14, 2020
Messages
85
Office Version
  1. 2013
Platform
  1. 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!
 

Excel Facts

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).
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...
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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?
 
Upvote 0
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
 
Upvote 0
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?
 
Upvote 0
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!
 
Upvote 0
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!
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,535
Messages
6,114,194
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top