PDA

View Full Version : Solved: check the A Cloumn and copy to aother sheet



parscon
03-10-2012, 05:29 AM
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
03-10-2012, 07:35 AM
Air code



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

parscon
03-10-2012, 08:38 AM
Thank you but , it is not work .

jonhaus
03-10-2012, 09:52 AM
I think this should work for you

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

-jonhaus

parscon
03-10-2012, 09:58 AM
Thank you , and it is work now .

parscon
03-10-2012, 11:05 AM
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
03-10-2012, 11:43 AM
Glad to here it worked. Try something like this.




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

parscon
03-10-2012, 11:55 AM
Thank you but delete dose not work .

jonhaus
03-10-2012, 01:52 PM
Are you getting an error? I don't have any problem running it.

parscon
03-10-2012, 01:54 PM
I run it but it does not delete .

jonhaus
03-10-2012, 02:13 PM
Give this a shot I forgot to account that for the cell locations changing when the row is deleted.



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

Bob Phillips
03-11-2012, 06:01 AM
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
03-11-2012, 12:07 PM
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
04-03-2012, 11:17 AM
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
04-03-2012, 12:33 PM
1) Sheets("Sheet2").Rows(Sheets("Sheet2").Range(Cells.count,1).Row).Insert
Shift:=xlDown
2) Dim x as Long (not Integer)
3) at start of code insert:
Application.ScreenUpdating = False
Application.DisplayAlerts = False
and at the end of your code set them both back to true

parscon
04-04-2012, 04:43 AM
Thanks to all . Now everything work fine .