Export cell data to closed workbook

[cluckers]

Is there a way to export a range of data of my current worksheet to the next
blank row on a closed workbook? I have a template excel file used to place
orders and I want to copy the order information (ex B3:F3) to the next
available row in a workbook that has all of the orders.

Thanks

 

[Ron de Bruin]

Hi cluckers

Maybe this will help

See the last example on this page : What if the Database sheet is in another workbook
http://www.rondebruin.nl/copy1.htm

 

[cluckers]

Thanks for the post. However, I have gotten the macro to work but sometimes
it does not always exoprt the data to the destination workbook. Do you know
why this sometimes does not work?

 

[Ron de Bruin]

Show us your code then

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

 

[cluckers]

At the end I am calling another macro to automcatically run. Combining them
into one was not working very well.



Option Explicit

Sub Send_To_Database()

If MsgBox("Are you sure you want to submit this order?", vbYesNo) = vbNo
Then Exit Sub

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

If bIsBookOpen_RB("Orders.xls") Then
Set DestWB = Workbooks("Orders.xls")
Else
Set DestWB = Workbooks.Open("G:\Destination path\Orders.xls")
End If

Set SourceRange = ActiveWorkbook.Sheets("Sheet1").Range("B12:L12")

Set DestSh = DestWB.Worksheets("Sheet1")


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


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

Call Email_Data

End Sub

 

[Ron de Bruin]

We are not able to help you if you not tell what you want and what the macro
Email_Data is trying to do.

Post this macro here




--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

 

[cluckers]

I sort of combined two macros to get what I wanted. Basically I want to also
save the current worksheet and email it. This macro first saves it as a temp
file emails the temp file then saves the file to my shared drive.

We are not able to help you if you not tell what you want and what the macro
Email_Data is trying to do.

Post this macro here

Option Explicit

Sub Email _Data()

' existing code
'Working in 2000-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim DestWB As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object


Dim FN As String
FN = ActiveSheet.Range("D12").Value


Dim FN1 As String
FN1 = ActiveSheet.Range("G12").Value

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

Set Sourcewb = ActiveWorkbook

'Copy the sheet to a new workbook
ActiveSheet.Copy
Set DestWB = ActiveWorkbook

'Determine the Excel version and file extension/format
With DestWB
If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007, we exit the sub when your answer is
'NO in the security dialog that you only see when you copy
'an sheet from a xlsm file with macro's disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False

'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = FN & "_" & FN1 & "_" _
& Format(Now, "mm-dd-yy")

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

With DestWB
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = "Destination email"
.CC = ""
.BCC = ""
.Subject = "Order"
.Body = ""
.Attachments.Add DestWB.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With

'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

Dim Path As String
Path = "G:\Destination path\Orders"
ActiveSheet.SaveAs Path & "\" & FN & "_" & Format(Now(), "mm-dd-yyyy") & "_"
& FN1


End Sub

 

[Ron de Bruin]

Why not save in direct in the correct place and delete this line

Kill TempFilePath & TempFileName & FileExtStr


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm