Code works only when...

[BHranek]

I wrote this procedure to transfer only some of the data from one sheet to another. Some qualifications will be added to the transfer later, but its not performing exactly the way I expect.

The code works perfectly when the active sheet is "Sheet1" but when any other sheet is the active sheet, the procedure stops after transfering only one row of data. Any ideas why or suggestions on how to fix it without specifying an active sheet?

'**************************
Sub TransferActiveItems()

Dim rgLast As Range
Dim lLastRow As Long, i As Long
Dim wsOrigSheet As Worksheet
Dim wsDestSheet As Worksheet
Dim sIName As String, sStop As String
Dim vINumber As Variant
Dim dSDate As Date, dEDate As Date

'assign the 2 worksheets to use
Set wsOrigSheet = Worksheets("Sheet1&quot
Set wsDestSheet = Worksheets("Sheet2&quot

'find the last row
Set rgLast = wsOrigSheet.Range("a1&quot.SpecialCells(xlCellTypeLastCell)
lLastRow = rgLast.Row

i = 1
With wsOrigSheet
sStop = .Cells(1, 1) 'used to look for the end of the data
End With

Do Until IsEmpty(sStop) Or sStop = "" 'look for the end of the data

'get the values to be transfered
With wsOrigSheet
sIName = .Cells(i, 2).Value
vINumber = .Cells(i, 1).Value
dSDate = .Cells(i, 8).Value
dEDate = .Cells(i, 9).Value
End With

'transfere the values
With wsDestSheet
.Cells(i, 1).Value = vINumber
.Cells(i, 2).Value = sIName
.Cells(i, 3).Value = dSDate
.Cells(i, 4).Value = dEDate
End With

i = i + 1
With wsOrigSheet
sStop = Cells(i, 1) 'used to look for the end of the data
End With

Loop

End Sub
'************************

 

[tony813]

Hello BHranek,
You may want to try the following:

Sub TransferActiveItems()

Dim rgLast As Range
Dim lLastRow As Long, i As Long
Dim wsOrigSheet As Worksheet
Dim wsDestSheet As Worksheet
Dim sIName As String
Dim vINumber As Variant
Dim dSDate As Date, dEDate As Date

'assign the 2 worksheets to use
Set wsOrigSheet = Worksheets("Sheet1&quot
Set wsDestSheet = Worksheets("Sheet2&quot

'find the last row
Set rgLast = wsOrigSheet.Range("a1&quot.SpecialCells(xlCellTypeLastCell)
lLastRow = rgLast.Row + 1
i = 1

Do Until lLastRow = i
With wsOrigSheet
sIName = .Cells(i, 2).Value
vINumber = .Cells(i, 1).Value
dSDate = .Cells(i, 8).Value
dEDate = .Cells(i, 9).Value
End With

'transfere the values
With wsDestSheet
.Cells(i, 1).Value = vINumber
.Cells(i, 2).Value = sIName
.Cells(i, 3).Value = dSDate
.Cells(i, 4).Value = dEDate
End With

i = i + 1
Loop

End Sub

tony_813

 

[BHranek]

Worked like a charm!!!!
Thanks Tony!