Need assistance with code, please

[winnie123]

Hi,

I am using Rons code to copy a range from one workbook to another and it
works well. The problem I am having is that the source range is not always
the same number of rows but will always have the same number of columns. So I
am getting blank rows inserted into destination workbook (which happens to be
a LIST). My source range is A2:AA1000, How can I change the code below so
that my source range will only copy to the last row of data.

Your help appreciated as always

Thanks
Winnie




Sub Copy_To_DATA2009_Workbook()
Dim SourceRange As Range
Dim DestRange As Range
Dim DestWB As Workbook
Dim DestSh As Worksheet
Dim Lr As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Change the file name (2*) and the path/file name to your file
If bIsBookOpen_RB("DATA 2009.xls") Then
Set DestWB = Workbooks("DATA 2009.xls")
Else
Set DestWB = Workbooks.Open("C:\Spares sales\DATA 2009.xls")
End If

'Change the Source Sheet and range
Set SourceRange = ThisWorkbook.Sheets("SALES1").Range("A2:AA1000")
'Change the sheet name of the database workbook
Set DestSh = DestWB.Worksheets("2009")


Lr = LastRow(DestSh)
Set DestRange = DestSh.Range("A" & Lr + 1)

'We make DestRange the same size as SourceRange and use the Value
'property to give DestRange the same values
With SourceRange
Set DestRange = DestRange.Resize(.Rows.Count, .Columns.Count)
End With
DestRange.Value = SourceRange.Value

DestWB.Close savechanges:=True

With Application
.ScreenUpdating = True
.EnableEvents = True

End With
End Sub

 

[Joel]

I need to know more about your worksheet and where the blank row(s) are
located. There are few methods that may solve your problem.

1) If there are no blank rows (or cell) in your data you can use end(xldown).
2) If there are no data below your table you can use End(xlup) and select
the last row of the worksheet.
3) If you have blank data in the middle of your data the PasteSpecial has
ignore blanks option. I have found that this often doesn't work

4) I've found that doing a sort in Descending order will move the blanks to
the bottom of the table.

 

[winnie123]

Hi Joel,

I run a monthly report for sale of parts so the column A:AA will always be
there.
The number of rows is dependant on how many sales there has been, so one
month it could be 200 rows, the next it could be 599 rows. I generate the
report from the AS/400 and use a rive mask to put it into excell, then copy
it to my source file.

There are no blank rows below the last line of data in my source file
Where would I put the end(xldown).

Thanks
Winnie

 

[Mike H]

Winnie,

I'm surprised you say this works well because from what you've posted it
doesn't

This bit suggests you call another sub to test if the workbook is open so
i'll assume it works and leave it at that. I commented it out to make the
code work for me

If bIsBookOpen_RB("DATA 2009.xls") Then
Set DestWB = Workbooks("DATA 2009.xls")
Else
Set DestWB = Workbooks.Open("C:\Spares sales\DATA 2009.xls")
End If

I think this is the cause of your problem

Set SourceRange = ThisWorkbook.Sheets("SALES1").Range("A2:AA1000")

Note in my revised code AA1000 is changed to be the actual used rows

Likewise this bit doesn't work If you look at the change in my code below
Lastrow and as a result Lr now are set with a value of the last used row of
DestSh

Lr = LastRow(DestSh)
Set DestRange = DestSh.Range("A" & Lr + 1)

Sub Copy_To_DATA2009_Workbook()
Dim SourceRange As Range
Dim DestRange As Range
Dim DestWB As Workbook
Dim DestSh As Worksheet
Dim Lr As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Change the file name (2*) and the path/file name to your file
' If bIsBookOpen_RB("DATA 2009.xls") Then
Set DestWB = Workbooks("DATA 2009.xls")
' Else
' Set DestWB = Workbooks.Open("C:\Spares sales\DATA 2009.xls")
'End If

'Change the Source Sheet and range
LastrowSrc = Sheets("SALES1").Cells(Rows.Count, "A").End(xlUp).Row
Set SourceRange = ThisWorkbook.Sheets("SALES1").Range("A2:AA" &
LastrowSrc)
'Change the sheet name of the database workbook
Set DestSh = DestWB.Worksheets("2009")

LastRow = DestSh.Cells(Rows.Count, "A").End(xlUp).Row
Lr = LastRow
Set DestRange = DestSh.Range("A" & Lr + 1)

'We make DestRange the same size as SourceRange and use the Value
'property to give DestRange the same values
With SourceRange
Set DestRange = DestRange.Resize(.Rows.Count, .Columns.Count)
End With
DestRange.Value = SourceRange.Value

' DestWB.Close savechanges:=True

With Application
.ScreenUpdating = True
.EnableEvents = True

End With
End Sub

Mike

 

[Joel]

Her is my version of the LastRow Function

Function LastRow(sht)

LastRow = sht.Range("A" & Rows.Count).End(xlup).Row

End Function

 

[winnie123]

I have copied your code and I get a Compile error, argument not optional on
the
line LastRow = DestSh.Cells(Rows.Count, "A").End(xlUp).Row

I am sorry I am pretty useless when it comes to macro's

I also have the functions below above my code, not sure if this makes any
difference. I copied them from Rons page as without it the macro didnt seem
to work

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function


Function bIsBookOpen_RB(ByRef szBookName As String) As Boolean
' Rob Bovey
On Error Resume Next
bIsBookOpen_RB = Not (Application.Workbooks(szBookName) Is Nothing)
End Function

Thank you

 

[Mike H]

Winnie,

Now that makes a lot more sense with those funxtions,

Try this

Sub Copy_To_DATA2009_Workbook()
Dim SourceRange As Range
Dim DestRange As Range
Dim DestWB As Workbook
Dim DestSh As Worksheet
Dim Lr As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Change the file name (2*) and the path/file name to your file
If bIsBookOpen_RB("DATA 2009.xls") Then
Set DestWB = Workbooks("DATA 2009.xls")
Else
Set DestWB = Workbooks.Open("C:\Spares sales\DATA 2009.xls")
End If
'Change the Source Sheet and range
LastRowsrc = ThisWorkbook.Sheets("SALES1").Cells(Rows.Count,
"H").End(xlUp).Row
Set SourceRange = ThisWorkbook.Sheets("SALES1").Range("A2:AA" &
LastRowsrc)
'Change the sheet name of the database workbook
Set DestSh = DestWB.Worksheets("2009")


Lr = LastRow(DestSh)
Set DestRange = DestSh.Range("A" & Lr + 1)

'We make DestRange the same size as SourceRange and use the Value
'property to give DestRange the same values
With SourceRange
Set DestRange = DestRange.Resize(.Rows.Count, .Columns.Count)
End With
DestRange.Value = SourceRange.Value

DestWB.Close savechanges:=True

With Application
.ScreenUpdating = True
.EnableEvents = True

End With
End Sub

Mike

 

[winnie123]

Thanks Mike, it works like a dream.

Winnie

Winnie,

Now that makes a lot more sense with those funxtions,

Try this

Sub Copy_To_DATA2009_Workbook()
Dim SourceRange As Range
Dim DestRange As Range
Dim DestWB As Workbook
Dim DestSh As Worksheet
Dim Lr As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Change the file name (2*) and the path/file name to your file
If bIsBookOpen_RB("DATA 2009.xls") Then
Set DestWB = Workbooks("DATA 2009.xls")
Else
Set DestWB = Workbooks.Open("C:\Spares sales\DATA 2009.xls")
End If
'Change the Source Sheet and range
LastRowsrc = ThisWorkbook.Sheets("SALES1").Cells(Rows.Count,
"H").End(xlUp).Row
Set SourceRange = ThisWorkbook.Sheets("SALES1").Range("A2:AA" &
LastRowsrc)
'Change the sheet name of the database workbook
Set DestSh = DestWB.Worksheets("2009")


Lr = LastRow(DestSh)
Set DestRange = DestSh.Range("A" & Lr + 1)

'We make DestRange the same size as SourceRange and use the Value
'property to give DestRange the same values
With SourceRange
Set DestRange = DestRange.Resize(.Rows.Count, .Columns.Count)
End With
DestRange.Value = SourceRange.Value

DestWB.Close savechanges:=True

With Application
.ScreenUpdating = True
.EnableEvents = True

End With
End Sub

Mike

 

[Mike H]

Glad I could help

Thanks Mike, it works like a dream.

Winnie