198188

帖子: 514
主題: 71
精華: 0
積分: 610
點名: 1
作業系統: win7
軟體版本: office 2010
閱讀權限: 50
性別: 男
註冊時間: 2012-10-30
最後登錄: 2025-10-31

1^# 跳轉到 » 正序看帖

字體大小: tT

發表於 2012-11-18 11:01 | 只看該作者

合併一個excel內的幾個worksheet的內容在另一個excel內的一個worksheet內

合併3個EXCEL.rar (18.97 KB)
Private Sub cmdMerge_Click()
Dim a, b, c As Integer '宣告A,B,C為整數
Dim objsheet As Worksheet

Source = Excel.ActiveWorkbook.Name '新檔案視窗編號

n = Range("b3")
m = Range("b4")

hmerger = UCase(Range("b5")) '是否為水平合併
'將之前合併的結果清除
Sheet2.Range("A:AB").Clear

z = 1
i = 1

Filename1 = Range("b" & 6) & "." & Range("b2")
Filename2 = Range("b" & 7) & "." & Range("b2")
Filename3 = Range("b" & 8) & "." & Range("b2")

Workbooks.Open Filename:=Excel.Workbooks(Source).Path & "\" & Filename1
Workbooks.Open Filename:=Excel.Workbooks(Source).Path & "\" & Filename2
Workbooks.Open Filename:=Excel.Workbooks(Source).Path & "\" & Filename3

WorkName = Excel.ActiveWorkbook.Name '

樓主熱帖

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 267
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2025-10-31

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

4^#

發表於 2012-11-20 08:27 | 只看該作者

回復 3# 198188

workbooks.open主要是filename引數的取得
filename是活頁簿的路徑包含檔案名稱所組成的字串
想想如何得到此字串是解決問題的根本
論壇中此類文章甚多可以參考

學海無涯_不恥下問

TOP

198188

高中生 Rank: 3 Rank: 3

帖子: 514
主題: 71
精華: 0
積分: 610
點名: 1
作業系統: win7
軟體版本: office 2010
閱讀權限: 50
性別: 男
註冊時間: 2012-10-30
最後登錄: 2025-10-31

3^#

發表於 2012-11-19 23:36 | 只看該作者

回復 2# Hsieh

請問如果將幾個不同的excel合併可以嗎？這個只是將一個excel的不同worksheet合併。但不同的excel我就想不到，怎樣解決？

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 267
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2025-10-31

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

2^#

發表於 2012-11-18 12:11 | 只看該作者

回復 1# 198188

Private Sub cmdMerge_Click()
Dim wb As Workbook, msh As Worksheet, mxsh As Worksheet, fs As String, sh, Tr As Range
Application.ScreenUpdating = False
fd = ThisWorkbook.Path & "\" '檔案目錄"
Set msh = ThisWorkbook.Sheets("參數設定")
Set mxsh = ThisWorkbook.Sheets("合併結果")
fs = fd & msh.[B1] & "." & msh.[B2]
If Dir(fs) = "" Then MsgBox "檔案目錄錯誤請檢查": Exit Sub
mxsh.Cells.Clear
Set wb = Workbooks.Open(fs)
For Each sh In msh.Range(msh.[B6], msh.[B6].End(xlDown))
With wb.Sheets(CStr(sh))
If Tr Is Nothing Then Set Tr = .Range(.[A1], .[A1].End(xlToRight)): Tr.Copy mxsh.[A1]
.Range("A1").CurrentRegion.Offset(msh.[B4], msh.[B3] - 1).Copy mxsh.[A65536].End(xlUp).Offset(1)
End With
Next
wb.Close 0
MsgBox "合併完成"
Application.ScreenUpdating = True
End Sub

複製代碼

學海無涯_不恥下問

TOP