麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 檔案中的兩個Sheet 複製到新的檔案問題 [打印本頁]

作者: jackyliu 時間: 2013-8-26 21:22 標題: 檔案中的兩個Sheet 複製到新的檔案問題

目的:A檔案(test01.xls)的樞紐整理完畢後,將A檔案的其中幾個Sheets(TEST、RAW;TEMP不要COPY)內容複製到B檔案儲存,並依儲存日期時間命名.

目前VBA內容已有 1.檔案命名, 2.A檔案的Sheets複製會新增一個Execl檔案,後續動作,一直試不出來,無言,麻煩版大幫忙了

作者: owen06 時間: 2013-8-26 23:17

hello，你是不是忘了上傳檔案了呢？

作者: jackyliu 時間: 2013-8-27 21:13

目的:A檔案(test01.xls)的樞紐整理完畢後,將A檔案的其中幾個Sheets(TEST、RAW;TEMP不要COPY)內容複製到B檔案 ...
jackyliu 發表於 2013-8-26 21:22

補上檔案...

作者: Hsieh 時間: 2013-8-28 08:42

本帖最後由 Hsieh 於 2013-8-28 08:46 編輯

回復 1# jackyliu

Sub Copy_Sheet()
Sheets(Array("TEST", "RAW")).Copy
fs="D:\" & Format(Date, "yyyy_mm_dd") & ".xls" '存檔檔名
ActiveWorkbook.SaveAs FileName:= fs,FileFormat:=-4143
End Sub

複製代碼

作者: jackyliu 時間: 2013-8-28 13:43

回復 4# Hsieh
我將code 轉修改到其他檔案 , 有些檔案有五個sheet 要轉存到新的檔案,
且sheet 不連續;　我用您的方式，將其他 sheet名稱加入到 Sheets(Array("TEST", "RAW", "TODAY","YESDAY","NOW")).Copy , 這樣會出現錯誤耶 !

作者: GBKEE 時間: 2013-8-28 14:35

回復 5# jackyliu
檢查一下工作表的名稱 "TEST", "RAW", "TODAY","YESDAY","NOW"是否有誤!
有"TEST "," TEST" 這情況嗎?

作者: jackyliu 時間: 2013-8-28 14:47

回復 6# GBKEE

檢查一下工作表的名稱 "TEST", "RAW", "TODAY","YESDAY","NOW"是否有誤!
有"TEST "," TEST" 這情況嗎?
回覆GBKEE: 檢查一下,應該沒錯, Sheets(Array("TEST", "RAW", "TODAY","YESDAY","NOW")).Copy ,好像只能複製兩個sheet,
三個以上就不行了 !

順道一提,依日期時間產生的檔案,要如何mail出去,
我之前都是一直指定同一個檔案,但目前做法是要將
剛才產生的mail出去,可否指導一下 !

CDO_Mail_Object.AddAttachment "D:\TEMP\test.xls"

作者: GBKEE 時間: 2013-8-28 15:07

回復 7# jackyliu
2003 沒這限制

參考[彰化一整天的blog]的檔案

[attach]15867[/attach]

作者: c_c_lai 時間: 2013-8-28 15:30

回復 GBKEE

檢查一下工作表的名稱 "TEST", "RAW", "TODAY","YESDAY","NOW"是否有誤!
有"TEST "," TES ...
jackyliu 發表於 2013-8-28 14:47

Sub Copy_Sheet()
Sheets(Array("TEST", "RAW", "TODAY", "YESDAY", "NOW")).Copy ' 同時複製 "TEST"、以及 "RAW" 等五個工作表單
fs = ThisWorkbook.Path & "\" & Format(Date, "yyyy_mm_dd") & ".xls" ' 存檔檔名
ActiveWorkbook.SaveAs FileName:=fs, FileFormat:=-4143
End Sub

複製代碼

這語法是正確的，GBKEE版大用的是 2003，而我是使用 2010，
請檢查妳的程式碼。

作者: jackyliu 時間: 2013-8-28 15:30

回復 8# GBKEE
回覆GBKEE: 重新在檢查測試其他檔案,都不行複製三個以上的sheet! Sheets(Array("TEST", "RAW", "TODAY","YESDAY","NOW")).Copy ,

作者: c_c_lai 時間: 2013-8-28 15:44

回復 GBKEE
回覆GBKEE: 重新在檢查測試其他檔案,都不行複製三個以上的sheet! Sheets(Array("TEST", "RA ...
jackyliu 發表於 2013-8-28 15:30

附上檔案，請參考：
[attach]15869[/attach]

作者: jackyliu 時間: 2013-8-28 18:25

回復 11# c_c_lai
感謝c_c_lai ,大力幫忙 ! 複製新檔案完成,沒問題了
若將依日期時間產生的檔案,要mail出去,
我之前都是一直指定同一個檔案,但目前做法是要將
剛才產生的mail出去,可否指導一下 !

我之前附件寫法如下: 不知道要如何將剛產生的的檔案,要mail出去(日期時間命名檔案)
CDO_Mail_Object.AddAttachment "D:\TEMP\test.xls"

作者: c_c_lai 時間: 2013-8-28 19:16

回復 12# jackyliu
有關 Send Mail Using CDO，我從國外網站摘錄了一篇，請參考：

' Send Mail Using CDO
Public Sub testCDO()
' Purpose Demondtrate Sending an Email with an attachment using CDO (Collaboration Data Objects)
' Uses Late Binding - Does not need a reference to the Microsoft CDO For Windows library
' cdosys comes innstalled as standard on Windows 2K and higher workstations and servers
' This code will fail on NT4, Win 98, and Win 95 where the cdosys.dll is not present
' Author Ron Weiner [email protected]
' Copyrite © 2004-2005 WorksRite Software Solutions
' You may use this code example for any purpose what-so-ever with
' acknowledgement. However, you may not publish the code without
' the express, written permission of the author.
Const cdoSendUsingPort = 2
Const cdoBasic = 1
Dim objCDOConfig As Object, objCDOMessage As Object
Dim strSch As String
strSch = "http://schemas.microsoft.com/cdo/configuration/"
Set objCDOConfig = CreateObject("CDO.Configuration")
With objCDOConfig.Fields
.Item(strSch & "sendusing") = cdoSendUsingPort
.Item(strSch & "smtpserver") = "SMTP.ServerName.Com"
' Only used if SMTP server requires Authentication
.Item(strSch & "smtpauthenticate") = cdoBasic
.Item(strSch & "sendusername") = "[email protected]"
.Item(strSch & "sendpassword") = "YourPassword"
.Update
End With
Set objCDOMessage = CreateObject("CDO.Message")
With objCDOMessage
Set .Configuration = objCDOConfig
.from = "Senders Pretty Name"
.sender = "[email protected]"
.To = "[email protected]"
.Subject = "Sample CDO Message"
' Use TextBody to send Email in Plain Text Format
'.TextBody = "This is a test for CDO message"
' Use HTMLBody to send Email in Rich Text (HTML) Format
.HTMLBody = "Test CDO Rich Text this is not Bold But <B>This is!</B>"
' Adding Attachments is easy enough
.AddAttachment "c:\SomeFile.zip"
.AddAttachment "c:\SomeOtherFile.pdf"
' Un-Rem next line to get "Return Reciept Request"
'.MDNRequested = True
.Send
End With
Set objCDOMessage = Nothing
Set objCDOConfig = Nothing
End Sub

複製代碼

作者: jackyliu 時間: 2013-8-28 21:29

回復 13# c_c_lai

我在想fs得到新檔案名稱和路徑 , 將此訊息給 Sub sendmail()副程式, Sub sendmail()副程式就可以附加檔案方式,mail出去了....
Sub main()
fs = ThisWorkbook.Path & "\" & Format(Now, "yyyy_mm_dd hhmm") & ".xls" '存檔檔名
End Sub

Sub sendmail()副程式,這裡一直是不出來,要如何附加新建立的檔案(檔名為yyyy_mm_dd hhmm.xls)
CDO_Mail_Object.AddAttachment "D:\TEMP\test.xls" 這是我之前指定同一個檔案的方式,不知道要怎麼改
End Sub

以上, 請板大協助 !

作者: c_c_lai 時間: 2013-8-28 21:42

回復 14# jackyliu
這是妳所要的嗎？

Sub Ex()
Dim fs As String
fs = ThisWorkbook.Path & "\" & Format(Now, "yyyy_mm_dd hhmm") & ".xls"
sendmail(fs)
End Sub
Sub sendmail(fs As String)
CDO_Mail_Object.AddAttachment fs
CDO_Mail_Object.Send
End Sub

複製代碼

作者: c_c_lai 時間: 2013-8-29 08:10

回復 14# jackyliu
因為無法得到 SMTP Server 的位址，我把執行結果列示如下。
之前妳是如何傳送出去？能否把原稿上傳提供實務應用。
[attach]15871[/attach]
[attach]15872[/attach]

作者: c_c_lai 時間: 2013-8-29 08:38

回復 14# jackyliu
再修正後連結產生的訊息：(已經加入cdoSendUsingPort 等參數)
關鍵性應是無法正確連結 SMTP Server。
[attach]15874[/attach]

Sub sendEMail(fd As String)
Const cdoSendUsingPort = 2
Const cdoBasic = 1
Dim objEmail As Object, CDO_Config As Object
Dim SMTP_Config As Variant
Dim strSch As String
strSch = "http://schemas.microsoft.com/cdo/configuration/"
Set objEmail = CreateObject("CDO.Message") ' 建立 CDO 物件
On Error GoTo debugErr
Set CDO_Config = CreateObject("CDO.Configuration")
With CDO_Config.Fields
.Item(strSch & "sendusing") = cdoSendUsingPort
.Item(strSch & "smtpserver") = "SMTP.ServerName.Com"
' Only used if SMTP server requires Authentication
.Item(strSch & "smtpauthenticate") = cdoBasic
.Item(strSch & "sendusername") = "[email protected]"
.Item(strSch & "sendpassword") = ""
.Update
End With
With objEmail
Set .Configuration = CDO_Config
.From = "[email protected]" ' 寄件者（網域必須存在）
.To = "[email protected]" ' 收件者
.Subject = "CDO郵件測試" ' 郵件主旨
.TextBody = "郵件測試本文" ' 郵件內文
.AddAttachment fd
.Send
End With
debugErr:
If Err.Description <> "" Then MsgBox Err.Description
Set objEmail = Nothing
Set CDO_Config = Nothing
End Sub

複製代碼

作者: jackyliu 時間: 2013-8-29 11:23

回復 17# c_c_lai

我遇到新複製sheet的檔案超過25mb, mail發不出去...
還在想有其他方式嗎?

另外分享我的code
Sub sendmail(fs As String)
Dim CDO_Mail_Object As Object
Dim CDO_Config As Object
Dim SMTP_Config As Variant
Dim Email_Subject, Email_Send_From, Email_Send_To, Email_Cc, Email_Bcc, Email_Body As String
Email_Subject = "Today IB Bank List! (Attachment)"
Email_Send_From = "[email protected]"
Email_Send_To = "[email protected]"
Email_Cc = "[email protected]"
Email_Bcc = "[email protected]"
Email_Body = "test "
Set CDO_Mail_Object = CreateObject("CDO.Message")
On Error GoTo debugs
Set CDO_Config = CreateObject("CDO.Configuration")
CDO_Config.Load -1
Set SMTP_Config = CDO_Config.Fields
With SMTP_Config
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'please put your server name below
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "xxxx.xxx.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
With CDO_Mail_Object
Set .Configuration = CDO_Config
End With
CDO_Mail_Object.Subject = Email_Subject
CDO_Mail_Object.From = Email_Send_From
CDO_Mail_Object.To = Email_Send_To
CDO_Mail_Object.TextBody = Email_Body
CDO_Mail_Object.CC = Email_Cc 'Use if needed
CDO_Mail_Object.BCC = Email_Bcc 'Use if needed
CDO_Mail_Object.AddAttachment "D:\test.xls"

CDO_Mail_Object.Send
debugs:
If Err.Description <> "" Then MsgBox Err.Description
'Sheet1.Select
ThisWorkbook.Save
Application.DisplayAlerts = True
ThisWorkbook.Close
End Sub

作者: c_c_lai 時間: 2013-8-29 11:47

回復 18# jackyliu
妳的 SMTP Server 的 IP Address 是設定多少？

作者: jackyliu 時間: 2013-8-29 13:03

回復 19# c_c_lai

.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'please put your server name below
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "xxxx.xxx.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25

作者: jackyliu 時間: 2013-8-29 14:50

回復 4# Hsieh

有辦法將execl 的四個sheet 複製另存成圖檔嗎?
有解嗎?

作者: jackyliu 時間: 2013-8-29 21:22

回復 6# GBKEE

有辦法將execl 的四個sheet 複製另存成圖檔嗎?
Mail自動化有解嗎?

最終結果如圖片所示: 將execl檔案裡的四個sheet 複製另存成圖檔,並mail 出去...
附件就是outlook 寄出畫面，希望大家能夠幫忙和分享,感謝!

作者: Hsieh 時間: 2013-8-29 23:33

回復 21# jackyliu
工作表要存成圖檔?
這要看資料範圍大小而定，若無法完整顯示資料區域那將無法取得完整畫面

作者: jackyliu 時間: 2013-8-30 10:33

回復 23# Hsieh

主要是將execl檔案裡的四個sheet 內容, 用Outlook  mail方式寄出(自動化)
目前是人工手動開啟execl檔案 , 將四個sheet 內容用 cut圖軟體, 複製貼到 Outlook  mail方式寄出,
希望能有辦法,用vba處理.

這要看資料範圍大小而定，若無法完整顯示資料區域那將無法取得完整畫面
回覆:  1. sheet+範圍複製貼到 Outlook  mail方式寄出
      2. 直接將四個sheet , 複製貼到 Outlook  mail方式寄出
以上兩種作法,哪個做的出來?

作者: stillfish00 時間: 2013-8-30 11:29

回復 21# jackyliu

Sub RangeToPicture()
Dim rngSrc As Range
With ActiveSheet
Set rngSrc = .UsedRange
rngSrc.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
With .ChartObjects.Add(Left:=rngSrc.Left, Top:=rngSrc.Top, Width:=rngSrc.Width, Height:=rngSrc.Height)
.Chart.Paste
.Chart.Export "C:\pic1.jpg"
.Delete
End With
End With
End Sub

複製代碼

作者: jackyliu 時間: 2013-8-30 22:51

本帖最後由 jackyliu 於 2013-8-30 23:02 編輯

回復 25# stillfish00

原本測試檔案, Run起來沒問題; 後來我將code 轉到其他檔案上(四個sheet裡,共有六個樞紐資料,總共有28MB),
程式跑起來,就出問題,附上相關圖片...
[attach]15906[/attach][attach]15907[/attach][attach]15908[/attach]

大大: 有其他的方法嗎?能讓我mail出去嗎? 目前我都人工方式,將樞紐資料圈選後,
在到Outlook 操作選擇性貼上..點陣圖 ,再mail 出去 ~ 能夠自動化嗎?

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)