- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
回復 1# anny8888
試試看- Option Explicit
- Private Sub cmdMerge_Click()
- Dim objsheet As Worksheet, desc As Workbook, WorkName As Workbook, Filename As String
- Dim Sh As Worksheet, Used As Worksheet, Rng As Range, r As Range, i As Integer, n As Integer, j As Integer
- Set WorkName = ThisWorkbook '程式所在檔案名稱 'WorkName = Excel.ActiveWorkbook.Name '作用中檔案名稱
- Set desc = Excel.Workbooks.Add '開新的workbook
- i = 1
- While WorkName.ActiveSheet.Range("b" & i) <> ""
- Filename = WorkName.ActiveSheet.Range("b" & i) & ".xlsx"
- Workbooks.Open WorkName.Path & "\" & Filename '開啟檔案
- Workbooks(Filename).ActiveSheet.Copy desc.Sheets(1)
- ActiveSheet.Rows(1).Delete
- ActiveSheet.Name = Windows(WorkName).ActiveSheet.Range("b" & i)
- Windows(Filename).Close
- i = i + 1 '讀取下一個檔案名稱
- Wend
- Set Used = desc.Sheets("sheet1") '*** 開新的workbook*** Sheets("合併成的工作表")
- 'Application.DisplayAlerts = False '停止 刪除Sheet時 預設的警告
- For Each Sh In Sheets
- If Sh.Name <> Used.Name Then
- Set Rng = Used.UsedRange(Used.UsedRange.Rows.Count, 1)(1, 1)
- 'sh.UsedRange.Offset(1).Copy.Rng '複製來源有標頭
- Sh.UsedRange.Copy Rng '複製來源沒有標頭
- ' SH.Delete '刪除已經複製好的sheet
- End If
- Next
- 'Application.DisplayAlerts = True '恢復 刪除Sheet時 預設的警告
- Used.UsedRange.Sort key1:=Used.Range("P2"), order1:=xlAscending, Header:=xlNo
- Set Used = Sheets("sheet1")
- n = Used.UsedRange.Rows.Count
- MsgBox n
- For j = 2 To n
- If Used.Range("c" & j) <> "" And Used.Range("p" & j) = "" Then
- Used.Rows(j).Clear
- End If
- Next
- j = j + 1 '這 j = j + 1 有何作用 *****
- MsgBox "已將所有檔案匯入活頁中", , "Anny note"
- End Sub
|
|
發表於 2013-10-15 15:31
| 