Prev: MSCOMM32 Control in Excel 2003 VBA - Control Stopped working!!!
Next: VB to search a value in an array from a sheet then write another c
From: Slim Slender on 24 Feb 2010 22:10
I started out using the following code which I got from this site:

Public Sub CopyDatatoDatabase()
' by Dave Peterson
' The code depends on the last used cell in column A for both
ranges.

Dim rngToCopy As Range
Dim DestCell As Range
Dim wbk As Workbook

On Error Resume Next
Set wbk = Workbooks("somefile.xls")
On Error GoTo 0

If wbk Is Nothing Then
MsgBox "Opening the book now"
Set wbk = Workbooks.Open("somepath\somefile.xls")
End If

With ThisWorkbook.Worksheets("Data")
Set rngToCopy = .Range("A2:I" & .Cells(.Rows.Count,
"A").End(xlUp).Row)
End With

With Workbooks("somefile.xls").Worksheets("Database")
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With

rngToCopy.Copy Destination:=DestCell

And it worked fairly well except for a couple of things. The Source
wks has validation. During the pasting process I was prompted to
decide if I wanted to use this or that validation. The Destination
sheet ended up with validation. So, I tried to figure out how to paste
special values only. Also, I want to remove the data from the Source
sheet (effectively move it to the destination) but using rngToCopy.Cut
removed the validation and all formatting from the copied cells on the
source, so I tried .Copy and going back to Delete or Clear the source
sheet but every thing results in destroying the formatting.


Public Sub CopyDatatoDatabase()

Dim rngToCopy As Range
Dim DestCell As Range
Dim wbk1 As Workbook
Dim wbk2 As Workbook

Set wbk1 = ActiveWorkbook

On Error Resume Next
Set wbk2 = Workbooks("somefile.xls")
On Error GoTo 0

If wbk2 Is Nothing Then
Set wbk2 = Workbooks.Open(ActiveWorkbook.Path & "\somefile.xls")
End If

'Subscript out of range
With wbk1.Sheets("Data")
Set rngToCopy = .Range("A2:I" & .Cells(.Rows.Count,
"A").End(xlUp).Row)
End With

With wbk2.Sheets("Database")
If .FilterMode Then .ShowAllData
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
'rngToCopy.Cut Destination:=DestCell

rngToCopy.Copy

'Application Defined or Object Defined Error
DestCell.PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Application.CutCopyMode = False

rngToCopy.Clear

End Sub

Sometimes this works perfectly and other times I get the errors
indicated in the comments. Can anyone help me smooth this out to work
consistently moving the values only and leaving the formatting and
validation behind.
 | 
Pages: 1
Prev: MSCOMM32 Control in Excel 2003 VBA - Control Stopped working!!!
Next: VB to search a value in an array from a sheet then write another c