[發問] 合併2個SHEET及SORT

如何

網上找到合併SHEET的程式,一直卡在SORT的部份,
可否請大大看一下哪裏出錯了.

另外,若我合併的2個檔案在合併的SHEET(sheet1)中,第一欄加入檔案名稱,應該如何改....

mergertosheet.zip (92.75 KB)

樓主熱帖

Anny

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2013-10-15 15:31 | 只看該作者

回復 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

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

anny8888

小學生 Rank: 1

帖子: 9
主題: 4
精華: 0
積分: 13
點名: 0
作業系統: window7
軟體版本: office 2010
閱讀權限: 10
性別: 女
來自: HsinChu
註冊時間: 2013-10-14
最後登錄: 2014-6-26

3^#

發表於 2013-10-15 18:38 | 只看該作者

回復 2# GBKEE

一直卡在 ActiveSheet.Name = Windows(WorkName).ActiveSheet.Range("b" & i)

另外, 若我改成TXT FILE, 可以改成.... 可一直會卡在開啟txt檔案部份, 還有TXT FILE 會像附件有  " | "  "---" 要如何一併處理.
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) & ".txt"
      '開啟txt檔案
      Workbooks.OpenText Filename:=Excel.Windows(WorkName).Path & "\" & Filename, Origin:=950, StartRow:=8, DataType:=xlFixedWidth, FieldInfo:=Array( _
      Array(0, 1), Array(1, 1), Array(7, 1), Array(12, 1), Array(34, 1), Array(42, 1), Array(43, 1 _
      ), Array(51, 1), Array(53, 1), Array(61, 1), Array(63, 1), Array(71, 1), Array(73, 1), Array _
      (81, 1), Array(83, 1), Array(91, 1), Array(93, 1), Array(101, 1), Array(103, 1), Array(111, _
      1), Array(113, 1), Array(121, 1), Array(123, 1), Array(137, 1), Array(140, 1)), _
      TrailingMinusNumbers:=True

  '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

  Used.UsedRange.Sort key1:=Used.Range("P2"), order1:=xlAscending, Header:=xlNo

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 ' 要將所有的資料確認過

MsgBox "已將所有檔案匯入活頁中", , "Anny note"
End Sub

test1.zip (742 Bytes)