Solved: check the A Cloumn and copy to aother sheet

[parscon]

I need a help , i have a list . that some items have not data on column A but they have data on column B and .... , I need a Macro code check if column A is blank copy their row to another sheet .

Thank you so much .

[Bob Phillips]

Air code

[vba]

With Activesheet

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row

For i = 1 To lastrow

If .Cells(i, "A").Value = "" Then

nextrow = nextrow + 1

.Rows(i).Copy Worksheets("Sheet2").Cells(nextrow, "A")
End If
Next i
End With[/vba]

[parscon]

Thank you but , it is not work .

[jonhaus]

I think this should work for you

[VBA]Dim i As Integer

Dim x As Integer

Dim lastrow As Integer

With ActiveSheet

lastrow = Range("B1").End(xlDown).row

x = 1

For i = 1 To lastrow
If .Cells(i, 1).Value = "" Then
.Rows(i).Copy
Sheets("Sheet2").Rows(x).PasteSpecial (xlPasteAll)
x = x + 1
End If
Next i
End With

End Sub[/VBA]

-jonhaus

[parscon]

Thank you , and it is work now .

[parscon]

Could you please helo me if i want to move or cut these data what can i do ?
that mean will not be in sheet A .

[jonhaus]

Glad to here it worked. Try something like this.


[vba]

Sub CopyRows()

Dim i As Integer

Dim x As Integer


Dim lastrow As Integer


With ActiveSheet

lastrow = Range("B1").End(xlDown).row

x = 1

For i = 1 To
lastrow
If .Cells(i, 1).Value = "" Then

.Rows(i).Copy

Sheets("Sheet2").Rows(x).Insert Shift:=xlDown

.Rows(i).Delete

x = x + 1
End If
Next i
End With


End Sub
[/vba]

[parscon]

Thank you but delete dose not work .

[jonhaus]

Are you getting an error? I don't have any problem running it.

[parscon]

I run it but it does not delete .

[jonhaus]

Give this a shot I forgot to account that for the cell locations changing when the row is deleted.

[vba]

Sub CopyRows()



Dim x As Integer



Dim lastrow As
Integer



With
ActiveSheet


x = 1


Do Until Len(Cells(x, 2).Value) = 0
If .Cells(x, 1).Value = "" Then



.Rows(x).Copy



Sheets("Sheet2").Rows(x).Insert
Shift:=xlDown



.Rows(x).Delete

Else

x = x + 1

End If
Loop

End With


End Sub

[/vba]

[Bob Phillips]

Give this a shot I forgot to account that for the cell locations changing when the row is deleted.

The trick is to work-bottom up when deleting not top-down, then the cell locations do not change.

[jonhaus]

Good idea! I have never thought of approaching it like that. I think my way will still work, but yours probably makes more since. Thanks.

[parscon]

I have Still the Problem with this code

Sub CopyRows()     
    Dim x As Integer    
    Dim lastrow As Integer 
    With ActiveSheet   
    x = 1 
    Do Until Len(Cells(x, 2).Value) = 0 
        If .Cells(x, 1).Value = "" Then 
         .Rows(x).Copy 
            Sheets("Sheet2").Rows(x).Insert 
            Shift:=xlDown 
            .Rows(x).Delete      
        Else              
            x = x + 1             
        End If 
    Loop     
End With 
End Sub 

1- This code will not copy to the first row of second sheet
2- i have 765233 row and when run this code i got error on 32767 Record. and when click on debug show me this line x = x + 1 and in my mouse hint show x= 32767 .
3- in there any other fast way ?

Thank you . Please help me on this subject .

[CatDaddy]

1) [VBA]Sheets("Sheet2").Rows(Sheets("Sheet2").Range(Cells.count,1).Row).Insert
Shift:=xlDown[/VBA]
2) [VBA]Dim x as Long[/VBA] (not Integer)
3) at start of code insert:
[VBA]Application.ScreenUpdating = False
Application.DisplayAlerts = False[/VBA]
and at the end of your code set them both back to true

[parscon]

Thanks to all . Now everything work fine .