Copy entire row if CountA <>0 to another sheet

[Harshil Mehta]

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!

 

[jolivanes]

If you would take some time and explain exactly what needs to happen when a certain condition is true, that would help.
Sorting through a code that does not make sense and doesn't work, as in your first post, is not the way to go.

 

[Fluff]

How about

Sub HarshilMehta()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long, cc As Long
   
   With Sheets(3)
      Ary = .Range("A6:AM" & .Range("D" & Rows.Count).End(xlUp).Row).Value2
   End With
   ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary, 2))
   For r = 1 To UBound(Ary)
      For c = 10 To UBound(Ary, 2)
         If Ary(r, c) <> "" Then
            nr = nr + 1
            For cc = 1 To UBound(Ary, 2)
               Nary(nr, cc) = Ary(r, cc)
            Next cc
            Exit For
         End If
      Next c
   Next r
   Sheets(1).Range("A1").Resize(nr, UBound(Ary, 2)).Value = Nary
End Sub

 

[Harshil Mehta]

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?

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

No. Instead of copying the entire row the code should copy rangeA:AM till the last row in column D of sheet3 if the condition is met and paste it in sheet1 one below the other

 

[Harshil Mehta]

No. Instead of copying the entire row the code should copy rangeA:AM till the last row in column D of sheet3 if the condition is met and paste it in sheet1 one below the other

I want to sort the data in such a way if the range J:AM of sheet3 are blank then move down and paste rangeA:AM of sheet3 to sheet1

Before:

id	name	Range J:M
1234	abc	USA	Americas	USA	Americas	USA	Americas
4567	gha
7894	tyfta	USA	Americas	USA	Americas	USA	Americas
9516	hgftys	USA	Americas	USA	Americas	USA	Americas

After:

id	name	Range J:M
1234	abc	USA	Americas	USA	Americas	USA	Americas
7894	tyfta	USA	Americas	USA	Americas	USA	Americas
9516	hgftys	USA	Americas	USA	Americas	USA	Americas
4567	gha

 

[Harshil Mehta]

If you would take some time and explain exactly what needs to happen when a certain condition is true, that would help.
Sorting through a code that does not make sense and doesn't work, as in your first post, is not the way to go.

I want to sort the data in such a way if the range J:AM of sheet3 are blank then move down and paste rangeA:AM of sheet3 to sheet1

Before:

id	name	Range J:M
1234	abc	USA	Americas	USA	Americas	USA	Americas
4567	gha
7894	tyfta	USA	Americas	USA	Americas	USA	Americas
9516	hgftys	USA	Americas	USA	Americas	USA	Americas

After:

id	name	Range J:M
1234	abc	USA	Americas	USA	Americas	USA	Americas
7894	tyfta	USA	Americas	USA	Americas	USA	Americas
9516	hgftys	USA	Americas	USA	Americas	USA	Americas
4567	gha

 

[Mentor82]

Hi,
Thanks for reply. Try this. This one places data from range A:AM to column D in sheet 1

Sub ABC()
Dim LastRow&
Dim newRow&
Dim strRange$
Dim arr
Dim arrTrans
Dim str$
LastRow= Sheets(3).Cells(Rows.Count, "d").End(xlUp).Row


For i = 7 To LastRow
    strRange =CStr ("J" & i & ":AM" & i)
    If WorksheetFunction.CountA(RANGE(strRange)) <> 0 Then
        newRow=Sheets(1).Cells(Cells.Rows.Count,"D").End(xlup).Row + 1
        str = "A" & i & ":AM" & i
        arr = Sheets(3).Range(str)
        arrTrans = WorksheetFunction.Transpose(arr)
        Sheets(1).Range("D" & newRow).Resize(UBound(arrTrans)) = arrTrans
    End If
Next

MsgBox "Done"

End Sub

 

[Fluff]

Have you tried the code in post#12?

 

[Harshil Mehta]

How about

Sub HarshilMehta()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long, cc As Long
  
   With Sheets(3)
      Ary = .Range("A6:AM" & .Range("D" & Rows.Count).End(xlUp).Row).Value2
   End With
   ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary, 2))
   For r = 1 To UBound(Ary)
      For c = 10 To UBound(Ary, 2)
         If Ary(r, c) <> "" Then
            nr = nr + 1
            For cc = 1 To UBound(Ary, 2)
               Nary(nr, cc) = Ary(r, cc)
            Next cc
            Exit For
         End If
      Next c
   Next r
   Sheets(1).Range("A1").Resize(nr, UBound(Ary, 2)).Value = Nary
End Sub

Sorry for late reply. This code worked well but what I am trying to do is copy the range if condition <>"" is met then copy range A:AM of sheet3 to sheet 1 till the last cell of column D in sheet3 and then reverse the condition to ="" and copy the copy range A:AM of sheet3 to sheet 1 till the last cell of column D in sheet3. I have pasted the code below for your reference.


Sub HarshilMehta()
Dim Ary As Variant, Nary As Variant
Dim r As Long, c As Long, nr As Long, cc As Long

With Sheets(3)
Ary = .Range("A7:AM" & .Range("D" & Rows.Count).End(xlUp).Row).Value2
End With
ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary, 2))
For r = 1 To UBound(Ary)
For c = 10 To UBound(Ary, 2)
If Ary(r, c) <> "" Then
nr = nr + 1
For cc = 1 To UBound(Ary, 2)
Nary(nr, cc) = Ary(r, cc)
Next cc
Exit For
End If
Next c
Next r
Sheets(1).Range("A2").Resize(nr, UBound(Ary, 2)).Value = Nary


With Sheets(3)
Ary = .Range("A7:AM" & .Range("D" & Rows.Count).End(xlUp).Row).Value2
End With
ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary, 2))
For r = 1 To UBound(Ary)
For c = 10 To UBound(Ary, 2)
If Ary(r, c) = "" Then
nr = nr + 1
For cc = 1 To UBound(Ary, 2)
Nary(nr, cc) = Ary(r, cc)
Next cc
Exit For
End If
Next c
Next r
Sheets(1).Range("A2").Resize(nr, UBound(Ary, 2)).Value = Nary

End Sub

The highlighted lines seems to b buggy.

 

[Harshil Mehta]

Hi,
Thanks for reply. Try this. This one places data from range A:AM to column D in sheet 1

I dont want my data to b transposed.

 

[Fluff]

How about

Sub HarshilMehta()
   Dim Ary As Variant, Nary As Variant, Nary2 As Variant
   Dim r As Long, c As Long, nr As Long, cc As Long, nr2 As Long
   Dim Flg As Boolean
   
   With Sheets(3)
      Ary = .Range("A6:AM" & .Range("D" & Rows.Count).End(xlUp).Row).Value2
   End With
   ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary, 2))
   ReDim Nary2(1 To UBound(Ary), 1 To UBound(Ary, 2))
   For r = 1 To UBound(Ary)
      Flg = True
      For c = 10 To UBound(Ary, 2)
         If Ary(r, c) <> "" Then
            Flg = False
            nr = nr + 1
            For cc = 1 To UBound(Ary, 2)
               Nary(nr, cc) = Ary(r, cc)
            Next cc
            Exit For
         End If
      Next c
      If Flg Then
         nr2 = nr2 + 1
         For cc = 1 To UBound(Ary, 2)
            Nary2(nr2, cc) = Ary(r, cc)
         Next cc
      End If
   Next r
   Sheets(1).Range("A1").Resize(nr, UBound(Ary, 2)).Value = Nary
   Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(nr2, UBound(Ary, 2)).Value = Nary2
End Sub