[發問] 合併2個SHEET及SORT 如何

anny8888

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

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

GBKEE

回復 1# anny8888
試試看

1. Option Explicit
   
2. Private Sub cmdMerge_Click()
   
3.     Dim objsheet As Worksheet, desc As Workbook, WorkName As Workbook, Filename As String
   
4.     Dim Sh As Worksheet, Used As Worksheet, Rng As Range, r As Range, i As Integer, n As Integer, j As Integer
   
5.     Set WorkName = ThisWorkbook       '程式所在檔案名稱  'WorkName = Excel.ActiveWorkbook.Name '作用中檔案名稱
   
6.     Set desc = Excel.Workbooks.Add    '開新的workbook
   
7.     i = 1
   
8.     While WorkName.ActiveSheet.Range("b" & i) <> ""
   
9.         Filename = WorkName.ActiveSheet.Range("b" & i) & ".xlsx"
   
10.         Workbooks.Open WorkName.Path & "\" & Filename    '開啟檔案
    
11.         Workbooks(Filename).ActiveSheet.Copy desc.Sheets(1)
    
12.         ActiveSheet.Rows(1).Delete
    
13.         ActiveSheet.Name = Windows(WorkName).ActiveSheet.Range("b" & i)
    
14.         Windows(Filename).Close
    
15.         i = i + 1 '讀取下一個檔案名稱
    
16.     Wend
    
17.     Set Used = desc.Sheets("sheet1")   '*** 開新的workbook*** Sheets("合併成的工作表")
    
18.     'Application.DisplayAlerts = False  '停止 刪除Sheet時 預設的警告
    
19.     For Each Sh In Sheets
    
20.         If Sh.Name <> Used.Name Then
    
21.             Set Rng = Used.UsedRange(Used.UsedRange.Rows.Count, 1)(1, 1)
    
22.             'sh.UsedRange.Offset(1).Copy.Rng  '複製來源有標頭
    
23.            Sh.UsedRange.Copy Rng            '複製來源沒有標頭
    
24.            ' SH.Delete                        '刪除已經複製好的sheet
    
25.         End If
    
26.     Next
    
27.     'Application.DisplayAlerts = True    '恢復 刪除Sheet時 預設的警告
    
28.     Used.UsedRange.Sort key1:=Used.Range("P2"), order1:=xlAscending, Header:=xlNo
    
29.     Set Used = Sheets("sheet1")
    
30.     n = Used.UsedRange.Rows.Count
    
31.     MsgBox n
    
32.     For j = 2 To n
    
33.         If Used.Range("c" & j) <> "" And Used.Range("p" & j) = "" Then
    
34.             Used.Rows(j).Clear
    
35.         End If
    
36.     Next
    
37.     j = j + 1   '這 j = j + 1 有何作用  *****
    
38.     MsgBox "已將所有檔案匯入活頁中", , "Anny note"
    
39. End Sub

複製代碼

anny8888

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

GBKEE

回復 3# anny8888
    一直卡在   ActiveSheet.Name = Windows(WorkName).ActiveSheet.Range("b" & i)

1. Workbooks(Filename).ActiveSheet.Copy desc.Sheets(1)
   
2.         desc.ActiveSheet.Rows(1).Delete
   
3.         desc.ActiveSheet.Name = WorkName.ActiveSheet.Range("b" & i)
   
4.         Application.Windows(Filename).Close

複製代碼

另外, 若我改成TXT FILE, 可以改成.... 可一直會卡在 開啟txt檔案部份, 還有TXT FILE 會像附件有  " | "  "---" 要如何一併處理.

1. " | "  "---"   很難處裡!!!

複製代碼

ui123

感謝分享基礎觀念跟知識