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

標題: [發問] 將資料自動複製到，目前點選的所在頁面並自動選擇最後一行空白處貼上 [打印本頁]

作者: starry1314 時間: 2015-4-16 00:32 標題: 將資料自動複製到，目前點選的所在頁面並自動選擇最後一行空白處貼上

想請問例如要將
1. 檔案1.xls內的第一個sheet內第二行的內容,使用巨集自動複製到另一個檔案2.xls內所在頁面的位置上需如何寫成巨集呢

作者: starry1314 時間: 2015-4-16 10:20

Sub 自動複製客戶明細()
'
' 自動複製客戶明細巨集
'
' 快速鍵: Ctrl+A
'
Windows("紀錄表-基礎.xls").Activate
Range("A2:M2").Select
Selection.Copy
Windows("客戶明細-業務專用.xlsm").Activate
ActiveSheet.Paste link:=True
End Sub

作者: PKKO 時間: 2015-4-16 12:04

回復 1# starry1314

因為檔案名稱以及分頁名稱都需要被指出
因此我假設檔案名稱A以及分頁名稱A1都是被拷貝的檔案

假設您的按鈕在檔案二的分頁上

可以直接使用

Sub test()
Workbooks("A").Sheets("A1").Rows(2).Copy
EndRow = ActiveSheet.UsedRange.Rows.Count + 1 '所有使用中的列數+1
Rows(EndRow).PasteSpecial Paste:=xlPasteValues
End Sub

作者: tyrone123456 時間: 2015-4-16 23:42

印象中的寫法
Workbooks("1.xls").Sheets("A1").Rows(2).Copy Workbooks("1.xls").Sheets("A1").cells(Workbooks("2.xls").Sheets("B1").UsedRange.Rows(1).Count + 1,1)

但此法會連同複製儲存格的格式，但上面大大的寫法則只會複製數值〈.PasteSpecial Paste:=xlPasteValues〉

作者: PKKO 時間: 2015-4-17 21:33

回復 4# tyrone123456

Workbooks("2.xls").Sheets("B1").UsedRange.Rows(1).Count + 1=>只會計算第一列使用的列數,因此永遠都是1+1=2
列數可能會有問題

作者: starry1314 時間: 2015-4-18 01:09

回復 starry1314

因為檔案名稱以及分頁名稱都需要被指出
因此我假設檔案名稱A以及分頁名稱A1都是被拷 ...
PKKO 發表於 2015-4-16 12:04

是說我原本的巨集指令完全替換成像你這樣的範例嗎??
Sub test()
Workbooks("紀錄表-基礎.xls").Sheets("客戶明細").Rows(2).Copy
EndRow = ActiveSheet.UsedRange.Rows.Count + 1 '所有使用中的列數+1
Rows(EndRow).PasteSpecial Paste:=xlPasteValues
End Sub

像這樣嗎? 另ROW(2)的意思是第二個檔案? 另workbooks的意思是?

我原本的巨集指令是只能達成固定檔名的自動複製貼上,但檔名只要不一樣就失敗了~所以想寫成
A複製到E
B複製到E1
C複製到E2
巨集儲在E

不管被烤或拷貝後都可以不均檔名,

作者: tyrone123456 時間: 2015-4-18 10:16

是有這個疑慮，但是理論上第一排應該都要有資料，例如ID編碼等唯一性的資料，而我不寫那種方式是曾經遇過非第一排位置的儲存格被"不小心"按到一空白資料，但是這在檢查過程是很難發現的異常，但卻造成資料到那一列就跳行，害我ㄧ直檢查程式是哪邊寫錯，最後當然才知道真正原因，而限制第一欄計算筆數，就可以立即看到問題

作者: tyrone123456 時間: 2015-4-18 10:24

ROW(2)的意思：代表該Sheet的第2"行"
workbooks的意思是? 如果你的複製貼上作業是在同一excel檔案，就可以忽略，但若是不同excel檔案，就像你這個case是不同檔案之間的內容複製，就要加入，而且starry的寫法意思要把基礎2.xls的資料複製到"目前活化的檔案的目前使用Sheet內"

我習慣寫詳細些，這樣Debug會較清楚，但缺點是多號一些資源
Workbooks("紀錄表-基礎.xls").Sheets("客戶明細").Rows(2).Copy
Workbooks("2.xls").Sheets("123").EndRow = Workbooks("2.xls").Sheets("123").UsedRange.Rows.Count + 1 '所有使用中的列數+1
Workbooks("2.xls").Sheets("123").Rows(EndRow).PasteSpecial Paste:=xlPasteValues

作者: starry1314 時間: 2015-4-19 01:32

回復 8# tyrone123456

Sub test()
Workbooks("紀錄表 ").Sheets("客戶明細").Rows(2).Copy
EndRow = ActiveSheet.UsedRange.Rows.Count + 1 '所有使用中的列數+1
Rows(EndRow).PasteSpecial Paste:=xlPasteValues
End Sub

可使用～但像 Workbooks("紀錄表 ").Sheets("客戶明細").Rows(2).Copy
變成只能使用固定檔名～可寫成將巨集存在哪個檔案裡就複製裡面sheets("客戶明細")的到目前所在的頁面嗎?
另如果要自動插入超連結要怎麼寫呢?GOOGLE找到的方法只變成自動貼上連結,無法讓他點選就跳選到當初複製過來的那個檔案裡面

作者: starry1314 時間: 2015-4-19 01:55

目前寫法
Sub test()
Workbooks("紀錄表 ").Sheets("客戶明細").Rows(2).Copy
EndRow = ActiveSheet.UsedRange.Rows.Count + 1 '所有使用中的列數+1
Rows(EndRow).PasteSpecial Paste:=xlPasteValues
ActiveSheet.Paste Link:=True
End Sub

作者: starry1314 時間: 2015-4-19 02:10

For I = 2 To Sheets.Count
ActiveSheet.Hyperlinks.Add Anchor:=Range("a" & I), Address:="", SubAddress:= _
Worksheets(I).Name & "!A1", TextToDisplay:=Sheets(I).Name
Next

有找到這種寫法.但不知道該如何整合進來,雖然會有超連結成功但不知道該怎麼調整在業務那邊會自動抓我SHEET1的連接貼過來,但在紀錄表那卻只會抓一個連結過來
可以麻煩幫我看看嗎|
[attach]20726[/attach]

作者: tyrone123456 時間: 2015-4-19 10:24

ActiveSheet.Hyperlinks.Add Anchor:=Range("A1"), Address:="", SubAddress:=Worksheets(I).Name & "!A1", TextToDisplay:=Sheets(I).Name

白話文：在這個頁面下增加一超連結， Anchor代表是哪一個儲存格要加入超連結,Address代表要連結到哪一個檔案〈意思是別的檔案名稱，例如address:="C:\ABC\DEF.xls")，SubAddress代表是那個檔案內的哪一個Sheet的儲存格位置〈根據你的例子，他剛好是在同一個檔案內，所以一來Address是空白，二來他是聯結到那個Sheet的儲存格A1，所以當你點那個連結時候，會直接跑到那個Sheet的A1位置〉，最後TexttoDisplay是說你希望那個儲存格內的聯結名稱，一般預設值是"Link"，根據你的例子是希望顯示連結Sheet的名稱

根據以上說明，應該就知道如何擴充了吧

作者: PKKO 時間: 2015-4-19 14:22

回復 9# starry1314

Workbooks("紀錄表 ").Sheets("客戶明細").Rows(2).Copy

若您想複製目前作業中的活頁簿,可以直接將前方去除即可=>Sheets("客戶明細").Rows(2).Copy

插入超連結的方式,若想在目前作業中的分頁插入超連結,參考下方方式,若想指定分頁,更改前方的ActiveSheet 為 sheets("XX")即可
ActiveSheet.Hyperlinks.Add Anchor:=Range("B6"), Address:="", SubAddress:= _
"項目設定!A1", TextToDisplay:="項目設定!A1"

作者: starry1314 時間: 2015-4-19 17:04

回復 12# tyrone123456

弄了一天還是弄不好.....連結會變成設在固定儲存格,不然就是無法參照的連結
1.我想做的是右邊的EXCEL資料自動複製到左方EXCEL,並自動貼至有資料的最後一列,並且自動插入可連結至右邊EXCEL檔案的連結

(但因右邊EXCEL,會有無數個不同檔名) <<所以想問說怎麼不均檔名,
因我照PKKO講的將Workbooks("紀錄表 ")拿掉就一直說偵錯不知道哪邊寫錯了

[attach]20731[/attach]

作者: starry1314 時間: 2015-4-19 17:12

回復 13# PKKO

還是沒辦法說,直接拿掉剩Sheets("客戶明細").Rows(2).Copy 會一直跑偵錯,
且我想寫成巨集存在的EXCEL裡面的指定SHEET自動複製到我目前畫面上的頁面並自動貼上超聯結,不知有辦法嗎?
現在算完成一半了,已經可寫成複製連結到我所要的EXCEL裡面,但都是必須有一個EXCEL要指定檔名

作者: tyrone123456 時間: 2015-4-19 18:03

你應該已經會寫資料貼到最後一筆的VBA程式，所以你也應該知道如何取得最後一筆的行位，接下來只要在該行狀態下，在最後一欄的儲存格將上述的超連結路徑加入，就完成了
靜下心，再思考ㄧ下，就可以寫出VBA程式了

作者: starry1314 時間: 2015-4-19 19:46

回復 16# tyrone123456

好的~我再試試,如何將貼入超連結的寫法加入

作者: starry1314 時間: 2015-4-19 20:15

回復 16# tyrone123456

想請問一下
ActiveSheet.Hyperlinks.Add Anchor:=Range("A1"), Address:="", SubAddress:=Worksheets(I).Name & "!A1", TextToDisplay:=Sheets(I).Name
裡面的(I) 代表的是?

作者: tyrone123456 時間: 2015-4-19 20:52

就是Sheet的編號，因為你有使用For I = 2 to sheets.count，所以Sheets(I).name代表第I個Sheet的名字

For I = 2 To Sheets.Count
ActiveSheet.Hyperlinks.Add Anchor:=Range("a" & I), Address:="", SubAddress:= _
Worksheets(I).Name & "!A1", TextToDisplay:=Sheets(I).Name
Next

作者: starry1314 時間: 2015-4-19 21:37

回復 19# tyrone123456

Sub test()

Workbooks("紀錄表-基礎A").Sheets("客戶明細").Rows(2).Copy
EndRow = ActiveSheet.UsedRange.Rows.Count + 1 '所有使用中的列數+1
Rows(EndRow).PasteSpecial Paste:=xlPasteValues
For I = 2 To Sheets.Count
ActiveSheet.Hyperlinks.Add Anchor:=Range("a" & I), Address:="", SubAddress:= _
Worksheets(I).Name & "!A1", TextToDisplay:=Sheets(I).Name
Next

End Sub

1.目前這樣在業務那個檔案會複製第一個SHEET的超連結過來到SHEET2的第一欄
2.如果再基礎那個那個檔案執行巨集的話會變成A2的超連結至A1.
可以在麻煩教我怎麼解決嗎|

作者: PKKO 時間: 2015-4-20 00:33

回復 14# starry1314

不指定Workbooks代表使用目前的活頁簿

Sheets("客戶明細").Rows(2).Copy'代表目前使用活頁簿的"客戶明細"分頁的第二列進行複製
EndRow = ActiveSheet.UsedRange.Rows.Count + 1 '所有使用中的列數+1
Rows(EndRow).PasteSpecial Paste:=xlPasteValues'目前使用中的分頁,的最下方空白列貼上值

作者: starry1314 時間: 2015-4-20 21:37

回復 21# PKKO

感謝說明～另外有個想法
我寫成一個檔案是固定檔名的好了，
例如這樣
固定（業務專用ｃ－客戶明細）　　　　不固定（客戶資料）　　讓固定（業務專用ｃ－客戶明細）可以去自己抓取不固定（客戶資料）內的第二個分頁第２行，會來貼在固定（業務專用ｃ－客戶明細）空白資料的最後一行
固定（業務專用ｂ－客戶明細）　　　　不固定（客戶資料）
固定（業務專用ａ－客戶明細）　　　　不固定（客戶資料）

作者: jackson7015 時間: 2015-5-7 08:29

想借提問固定檔案檔名的分頁資料複製問題
想從資料表"當月報表"中建立巨集，作用如下
複製"當月報表"中的[綜合資料庫]的A5:AQ有值的最後一行
到
"全年度資料庫"資料表的[綜合資料庫]中的A列有值的下一行(空白處)

想詢問前輩們，以上巨集要如何編寫比較正確
如果沒有打開檔案"全年度資料庫"，請問會自動打開嗎?

作者: luhpro 時間: 2015-5-8 23:53

想借提問固定檔案檔名的分頁資料複製問題
想從資料表"當月報表"中建立巨集，作用如下
複製"當月報表"中的 ...
jackson7015 發表於 2015-5-7 08:29

Sub nn()
Dim lSRow&, lTRow&
Dim sPath$
Dim bNFind As Boolean
Dim wsSou As Worksheet, wsTar As Worksheet
Dim wbSou As Workbook, wbTar As Workbook
sPath = ThisWorkbook.Path
ChDrive sPath
ChDir sPath
Set wbSou = ThisWorkbook
Set wsSou = wbSou.Sheets("綜合資料庫")
bNFind = True
For Each wbTar In Workbooks ' 全年度資料庫檔案是否已開啟
If wbTar.Name = "全年度資料庫.xls" Then
Set wsTar = wbTar.Sheets("綜合資料庫")
bNFind = False
Exit For
End If
Next
If bNFind Then ' 若檔案未開啟則開啟它
With Workbooks.Open("全年度資料庫.xls", , True)
Set wbTar = ThisWorkbook
Set wsTar = .Sheets("綜合資料庫")
End With
End If
With wsSou
lSRow = .Cells(Rows.Count, [AQ1].Column).End(xlUp).Row ' 找末列
lTRow = wsTar.Cells(Rows.Count, 1).End(xlUp).Row
.Range([A5], .Cells(lSRow, [AQ1].Column)).Copy wsTar.Cells(lTRow, 1)
End With
End Sub

複製代碼

有些指令並無必要性,
只是一併列出來相關物件可以用怎樣的指令來取得.

若有先執行底下這三行,
sPath = ThisWorkbook.Path
ChDrive sPath
ChDir sPath
則只需要將檔案都放在同個目錄下,
讀檔指令中可以不用再給路徑.

作者: jackson7015 時間: 2015-5-12 09:04

回復 24# luhpro

感謝luhpro大大的回覆

巨集卡在

lSRow = .Cells(Rows.Count, [AQ1].Column).End(xlUp).Row ' 找末列

複製代碼

打開的全年度資料庫無誤
請問該如何排解?

作者: GBKEE 時間: 2015-5-12 15:48

回復 25# jackson7015
是這樣嗎?

lSRow = .Cells(.Rows.Count, .[AQ1].Column).End(xlUp).Row ' 找末列

複製代碼

作者: jackson7015 時間: 2015-5-12 16:16

本帖最後由 jackson7015 於 2015-5-12 16:17 編輯

回復 26# GBKEE

感謝GBKEE板大
原狀況排除了

但是又出了新狀況...
我的因為A4:AQ4都有值，所以我把[CTRL+↓]的指令改成從AQ4開始(End(xlUp)的意思應該是這樣沒錯吧?)
但是還出現問題

lTRow = wsTar.Cells(Rows.Count, 1).End(xlUp).Row
.Range([A5], .Cells(lSRow, [AQ4].Column)).Copy wsTar.Cells(lTRow, 1)

複製代碼

下面的列式有錯誤

.Range([A5], .Cells(lSRow, [AQ4].Column)).Copy wsTar.Cells(lTRow, 1)

複製代碼

再請前輩們分析看看
感謝~

作者: GBKEE 時間: 2015-5-12 16:48

回復 27# jackson7015
試試看

With wsTar
lTRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.[A5], .Cells(lSRow, .[AQ4].Column)).Copy .Cells(lTRow, 1)
End With

複製代碼

作者: jackson7015 時間: 2015-5-13 16:24

回復 28# GBKEE

先感謝GBKEE板主的回覆
錯誤訊息目前都排除了
但是卻出現沒有複製"當月報表"中的[綜合資料庫]到
"全年度資料庫"資料表的[綜合資料庫]中

反而出現
開啟"全年度資料庫"資料表的[綜合資料庫]中複製了a1:aq有值的最後一行
到
"全年度資料庫"資料表的[綜合資料庫]的空白處下方去了

是否可以再請幫忙看看哪裡有問題呢..

Sub nn()
Dim lSRow&, lTRow&
Dim sPath$
Dim bNFind As Boolean
Dim wsSou As Worksheet, wsTar As Worksheet
Dim wbSou As Workbook, wbTar As Workbook
sPath = ThisWorkbook.Path
ChDrive sPath
ChDir sPath
Set wbSou = ThisWorkbook
Set wsSou = wbSou.Sheets("綜合資料庫")
bNFind = True
For Each wbTar In Workbooks ' 全年度資料庫檔案是否已開啟
If wbTar.Name = "全年度資料庫.xlsm" Then
Set wsTar = wbTar.Sheets("綜合資料庫")
bNFind = False
Exit For
End If
Next
If bNFind Then ' 若檔案未開啟則開啟它
With Workbooks.Open("全年度資料庫.xlsm", , True)
Set wbTar = ThisWorkbook
Set wsTar = .Sheets("綜合資料庫")
End With
End If
With wsTar
lSRow = .Cells(.Rows.Count, .[AQ1].Column).End(xlUp).Row ' 找末列
lTRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.[A5], .Cells(lSRow, .[AQ4].Column)).Copy .Cells(lTRow, 1)
End With
End Sub

複製代碼

作者: GBKEE 時間: 2015-5-14 07:58

回復 29# jackson7015
試試看

Option Explicit
Sub Ex()
Dim E As Variant, wbSh(1 To 2) As Worksheet, bNFind(1 To 2) As Boolean
Dim AR(1 To 2), xPath As String, Rng As Range
AR(1) = "全年度資料庫.xls" '檔案名稱
AR(2) = "當月報表.xls" '檔案名稱
xPath = "D:\" '檔案的路徑
For Each E In Workbooks '所有開啟的活頁簿物件集合
If E.Name = AR(1) Then bNFind(1) = True '全年度資料庫已開啟
If E.Name = AR(2) Then bNFind(2) = True '當月報表已開啟
Next
For E = 1 To UBound(bNFind)
If Not bNFind(E) Then '檔案未開啟
Workbooks.Open (xPath & AR(E))
End If
Set wbSh(E) = Workbooks(AR(E)).Sheets("綜合資料庫")
Next
With wbSh(2) '當月報表"中的[綜合資料庫]
Set Rng = .Cells(.Rows.Count, .[AQ1].Column).End(xlUp) ' 找末列
Set Rng = .Range(.[A5], Rng)
End With
With wbSh(1) '全年度資料庫"資料表的[綜合資料庫]
Rng.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
End With
For Each E In AR
Workbooks(E).Close True '全年度資料庫,當月報表. 關閉且存檔
Next
End Sub

複製代碼

作者: jackson7015 時間: 2015-5-14 08:38

回復 30# GBKEE

感謝GBKEE版主修正後的版本
這版本程式碼比較簡單，而且有註譯也比較好讀了，不過有幾點可否幫忙要修正

1.因AQ有時候會沒有設定值，所以能否只判斷A列有幾行，然後複製A5:AQ(A列最後一行)
2.只儲存關閉"全年度資料庫"
3.只貼上"值"的部分就好
是否把

Rng.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1)

複製代碼

修正成

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

複製代碼

作者: GBKEE 時間: 2015-5-14 09:33

回復 31# jackson7015

Option Explicit
Sub Ex()
Dim E As Variant, wbSh(1 To 2) As Worksheet, bNFind(1 To 2) As Boolean
Dim AR(1 To 2), xPath As String, Rng As Range
AR(1) = "全年度資料庫.xls" '檔案名稱
AR(2) = "當月報表.xls" '檔案名稱
xPath = "D:\" '檔案的路徑
For Each E In Workbooks '所有開啟的活頁簿物件集合
If E.Name = AR(1) Then bNFind(1) = True '全年度資料庫已開啟
If E.Name = AR(2) Then bNFind(2) = True '當月報表已開啟
Next
For E = 1 To UBound(bNFind)
If Not bNFind(E) Then '檔案未開啟
Workbooks.Open (xPath & AR(E))
End If
Set wbSh(E) = Workbooks(AR(E)).Sheets("綜合資料庫")
Next
With wbSh(2) '當月報表"中的[綜合資料庫]
'***1.因AQ有時候會沒有設定值，所以能否只判斷A列有幾行，然後複製A5:AQ(A列最後一行)
'Set Rng = .Cells(.Rows.Count, .[AQ1].Column).End(xlUp) ' 找末列
Set Rng = .Cells(.Rows.Count, "AQ").End(xlUp) ' 找末列
If .[A5].End(xlDown).Row > Rng.Row Then
Set Rng = .Range(.[A5], .Range("AQ" & .[A5].End(xlDown).Row))
Else
Set Rng = .Range(.[A5], Rng)
End If
End With
With wbSh(1) '全年度資料庫"資料表的[綜合資料庫]
Rng.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
'***3.只貼上"值"的部分就好
.UsedRange = .UsedRange.Value
End With
'***2.只儲存關閉"全年度資料庫"
Workbooks(AR(1)).Close True '全年度資料庫. 關閉且存檔
End Sub

複製代碼

作者: jackson7015 時間: 2015-5-14 16:56

回復 32# GBKEE

感謝GBKEE版主的修正
動作方面都OK了，不過貼上值的部分會連儲存格式也貼上去，累積下來的量會使儲存格式部份暴增
本想自己更正，不過不明白那一行的作用到底是怎麼運行的
只好在懇請板主幫忙了

原本以為是改正

'***3.只貼上"值"的部分就好
.UsedRange = .UsedRange.Value

複製代碼

不過查詢了一下，此代碼的作用好像都是解釋為'去除公式，所以不太明白怎麼更正...

作者: jackson7015 時間: 2015-5-19 09:32

回復 32# GBKEE
不好意思，想請教GBKEE版主
這條列試還是不會修改，可否幫忙看看

Rng.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1)

複製代碼

有加入過

.PasteSpecial Paste:=xlPasteValues

複製代碼

不過語法錯誤..

抱歉，VB的能力真的很差
再請看看能否只貼上"值"，不需要格式條件

作者: GBKEE 時間: 2015-5-19 09:54

回復 34# jackson7015
反過來作

With wbSh(1) '全年度資料庫"資料表的[綜合資料庫]
'Rng.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
'***3.只貼上"值"的部分就好
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(Rng.Rows.Count, Rng.Columns.Count) = Rng.Value
'複製範圍的總列數 Rng.Rows.Count
'複製範圍的總欄數 Rng.Columns.Count
End With

複製代碼

作者: jackson7015 時間: 2015-5-19 16:31

回復 35# GBKEE

感謝GBKEE版主的幫忙
原來要使用另一種寫法來定義範圍
謝謝前輩們的指教~

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