If Then in VBA, check cell, enter data to other cell

[Win]

Hello all,
I am very new to Excel VBA stuff so I hope I explain this right. I have a
sheet that data pulled into from another worksheet. The data is pulled via
(=Sheet2!B19) being in the cell on sheet1. The number of rows below B19 can
vary.

After the data is worked, I want to be able to copy the results to a
different workbook. I have the code working to copy the rows but the problem
I have is that if I tell the code to select the last row with data in column
B it does not stop at the last row of new data since the function in the
cells creates a "0" (zero) in the cells.

I would like to get the code to check column B from B19 down, When it finds
a "0" (zero) think of that as the last row to copy. See below for the code I
am using now.

Sample of data...

A1 .... B1..... C1 ...> to V1
row19 Data data >>>>>
row20 data data >>>>
row21 0
& 0n 0

I need to come up with a way to have VBA find the row that = 0 or the other
way I thought of but can not code is to have VBA check for a zero in column B
and if find one enter a X in the cell to the left (A21) nin above sample.

my code as of now ...
Sub copy_to_another_workbook()
Dim sourceRange As Range
Dim destrange As Range
Dim destWB As Workbook
Dim Lr As Long

Application.ScreenUpdating = False
If bIsBookOpen("test.xls") Then
Set destWB = Workbooks("test.xls")
Else
Set destWB = Workbooks.Open("P:\COBdata\test.xls")
End If
Lr = LastRow(destWB.Worksheets("Sheet1")) + 1
'Set sourceRange =
ThisWorkbook.Worksheets("COB_Cover_Sheet").Range("A1:C10")

With ThisWorkbook.Worksheets("Sheet1")
Set sourceRange = .Range("B19:V" & .Range("A" &
Rows.Count).End(xlUp).Row)
End With


Set destrange = destWB.Worksheets("Sheet1").Range("A" & Lr)
sourceRange.Copy
destrange.PasteSpecial xlPasteValues, , False, False
Application.CutCopyMode = False
destWB.Close True
Application.ScreenUpdating = True
End Sub

 

[Tom Ogilvy]

Sub copy_to_another_workbook()
Dim sourceRange As Range
Dim destrange As Range
Dim destWB As Workbook
Dim Lr As Long

Application.ScreenUpdating = False
If bIsBookOpen("test.xls") Then
Set destWB = Workbooks("test.xls")
Else
Set destWB = Workbooks.Open("P:\COBdata\test.xls")
End If
Lr = LastRow(destWB.Worksheets("Sheet1")) + 1

' Set sourceRange = ThisWorkbook.Worksheets( _
' "COB_Cover_Sheet").Range("A1:C10")

With ThisWorkbook.Worksheets("Sheet1")
Set sourceRange = .Range("B19:V" & _
.Range("A" & Rows.Count).End(xlUp).Row
End With
for each cell in sourceRange.columns(1).cells
if cell.Value = 0 then
set sourceRange = sourcerange.Resize(cell.row - 19)
exit for
end if
Next

Set destrange = destWB.Worksheets("Sheet1").Range("A" & Lr)
sourceRange.Copy
destrange.PasteSpecial xlPasteValues, , False, False
Application.CutCopyMode = False
destWB.Close True
Application.ScreenUpdating = True
End Sub

 

[Win]

Tom,
Thank you for the reply, I tried the code and it stops at the line marked
with **'s., Might you have any ideas

Thank You Again

Win

 

[Tom Ogilvy]

It tested you code:

Sub copy_to_another_workbook()
Dim sourceRange As Range
Dim destrange As Range
Dim destWB As Workbook
Dim Lr As Long

Application.ScreenUpdating = False
' If bIsBookOpen("test.xls") Then
' Set destWB = Workbooks("test.xls")
' Else
' Set destWB = Workbooks.Open("P:\COBdata\test.xls")
' End If
' Lr = LastRow(destWB.Worksheets("Sheet1")) + 1

' Set sourceRange = ThisWorkbook.Worksheets( _
' "COB_Cover_Sheet").Range("A1:C10")

With ThisWorkbook.Worksheets("Sheet1")
Set sourceRange = .Range("B19:V" & _
.Range("A" & Rows.Count).End(xlUp).Row)
End With
For Each cell In sourceRange.Columns(1).Cells
If cell.Value = 0 Then
Set sourceRange = sourceRange.Resize(cell.Row - 19)
Exit For
End If
Next
sourceRange.Select
Exit Sub
Set destrange = destWB.Worksheets("Sheet1").Range("A" & Lr)
sourceRange.Copy
destrange.PasteSpecial xlPasteValues, , False, False
Application.CutCopyMode = False
destWB.Close True
Application.ScreenUpdating = True
End Sub


and it worked perfectly for me - especially for my contribution. If there
is a problem, it is probably that you don't have data extending down in
column A - but that was you code.

 

[Win]

It tested you code:

Sub copy_to_another_workbook()
Dim sourceRange As Range
Dim destrange As Range
Dim destWB As Workbook
Dim Lr As Long

Application.ScreenUpdating = False
' If bIsBookOpen("test.xls") Then
' Set destWB = Workbooks("test.xls")
' Else
' Set destWB = Workbooks.Open("P:\COBdata\test.xls")
' End If
' Lr = LastRow(destWB.Worksheets("Sheet1")) + 1

' Set sourceRange = ThisWorkbook.Worksheets( _
' "COB_Cover_Sheet").Range("A1:C10")

With ThisWorkbook.Worksheets("Sheet1")
Set sourceRange = .Range("B19:V" & _
.Range("A" & Rows.Count).End(xlUp).Row)
End With
For Each cell In sourceRange.Columns(1).Cells
If cell.Value = 0 Then
Set sourceRange = sourceRange.Resize(cell.Row - 19)
Exit For
End If
Next
sourceRange.Select
Exit Sub
Set destrange = destWB.Worksheets("Sheet1").Range("A" & Lr)
sourceRange.Copy
destrange.PasteSpecial xlPasteValues, , False, False
Application.CutCopyMode = False
destWB.Close True
Application.ScreenUpdating = True
End Sub


and it worked perfectly for me - especially for my contribution. If there
is a problem, it is probably that you don't have data extending down in
column A - but that was you code.

 

[Tom Ogilvy]

Was there a message here?

 

[Win]

Yes there should have been,

I am sorry Tom, you are correct... I did not have a zero in the row when I
ran the code

The code is working geat, I can not thank you enough.

Sorry againn for the confusion

Win