如何在窗口中鼠标点选工作薄导入指定工作表并按指定次序排放语文数学英语

yzyyyyyyy

点按钮，打开文件对话框，复选文件，将选定工作薄中指定工作表（若没有忽略，若有重复，则工作表名后加序号1，2，3）复制到汇总表，按指定顺序排序（语文，数学，英语），
如何在窗口中鼠标点选工作薄导入指定工作表并按指定次序排放语文数学英语.rar (7.14 KB, 下载次数: 18)

2015-5-29 11:19 上传

点击文件名下载附件

yzyyyyyyy

搜到大师的一段代码。想合并到同一工作薄中。
Sub 合并当前目录下所有工作簿的全部工作表()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xls")
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
.Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
For G = 1 To Sheets.Count
'Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
Wb.Sheets(G).Copy
        'Wb.Sheets(G).Copy After:=.Sheets(.Sheets.Count)
         '               Set sht = .Sheets(.Sheets.Count)

Next
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Range("B1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub

Private Sub CommandButton1_Click() '合并工作薄()
     Dim f_name As String
     Dim bok1 As Workbook, bok2 As Workbook
     Set bok2 = Nothing '设置为空
     f_name = Dir(ThisWorkbook.Path & "\" & "*.xls") '获得本文件夹下的工作簿名称
     Do While f_name <> "" And f_name <> ThisWorkbook.Name '不是空并且不是自己
         Set bok1 = Workbooks.Open(ThisWorkbook.Path & "\" & f_name) '打开它
         If bok2 Is Nothing Then 'bok2不是空就
             bok1.Sheets(1).Copy '拷贝打开的文件
             Set bok2 = ActiveWorkbook '激活bok2
             bok2.Sheets(1).Name = bok1.Name '用打开的文件名命名
         Else
             bok1.Sheets(1).Copy Before:=bok2.Sheets(1) '拷贝打开的文件到新工作表
             bok2.Sheets(1).Name = bok1.Name ''用打开的文件名命名
         End If
         bok1.Close '关闭打开的文件
         f_name = Dir() ''获得本文件夹下的工作簿名称
     Loop '循环

End Sub

Sub test() '合并工作薄()
     Dim f_name As String
     Dim bok1 As Workbook, bok2 As Workbook
     Set bok2 = Nothing '设置为空
     f_name = Dir(ThisWorkbook.Path & "\" & "*.xls") '获得本文件夹下的工作簿名称
     Do While f_name <> "" And f_name <> ThisWorkbook.Name '不是空并且不是自己
         Set bok1 = Workbooks.Open(ThisWorkbook.Path & "\" & f_name) '打开它
         If bok2 Is Nothing Then 'bok2不是空就
             bok1.Sheets(1).Copy '拷贝打开的文件
             Set bok2 = ActiveWorkbook '激活bok2
             bok2.Sheets(1).Name = bok1.Name '用打开的文件名命名
         Else
             bok1.Sheets(1).Copy Before:=bok2.Sheets(1) '拷贝打开的文件到新工作表
             bok2.Sheets(1).Name = bok1.Name ''用打开的文件名命名
         End If
         bok1.Close '关闭打开的文件
         f_name = Dir() ''获得本文件夹下的工作簿名称
     Loop '循环
End Sub

Sub zz() '合并工作薄()
    Dim f_name As String, bok1 As Workbook, bok2 As Workbook, d, sh As Worksheet
    Set d = CreateObject("Scripting.Dictionary")
    Set bok2 = Nothing '设置为空
    f_name = Dir(ThisWorkbook.Path & "\" & "*.xls") '获得本文件夹下的工作簿名称
    Do While f_name <> "" And f_name <> ThisWorkbook.Name '不是空并且不是自己
        Set bok1 = Workbooks.Open(ThisWorkbook.Path & "\" & f_name) '打开它
        If bok2 Is Nothing Then 'bok2不是空就
        bok1.Sheets(1).Copy '拷贝打开的文件
        Set bok2 = ActiveWorkbook '激活bok2
        bok2.Sheets(1).Name = Mid(Split(bok1.Name, ".")(0), 6) '用打开的文件名命名
    Else
        bok1.Sheets(1).Copy Before:=bok2.Sheets(1) '拷贝打开的文件到新工作表
        bok2.Sheets(1).Name = Mid(Split(bok1.Name, ".")(0), 6) ''用打开的文件名命名
    End If
    bok1.Close '关闭打开的文件
    f_name = Dir() ''获得本文件夹下的工作簿名称
Loop '循环
With bok2
    For i = 1 To .Sheets.Count  ' 字典取表名
        d("'" & .Sheets(i).Name) = ""
    Next
    With .Sheets(1)  ' 表名排序
        .Range("K1").Resize(d.Count, 1) = Application.Transpose(d.keys)
        .Range("K1").Resize(d.Count, 1).Sort Key1:=Range("K1"), Order1:=xlAscending, Header:=xlGuess
        sa = .Range("K1").Resize(d.Count, 1)
        .Range("K1").Resize(d.Count, 1).ClearContents
    End With
    For i = 1 To UBound(sa) ' 工作表排序及粘贴格式
        .Sheets(sa(i, 1)).Move Before:=.Sheets(i)
        ThisWorkbook.Sheets(1).Range("A1:I2").Copy
        .Sheets(sa(i, 1)).Range("A1").CurrentRegion.PasteSpecial Paste:=xlPasteFormats
    Next
    .Close True, ThisWorkbook.Path & "\工作簿汇总表.xls"
End With
End Sub

Sub test111() '在新工作簿上合并多工作簿的代码
     Dim f_name As String
     Dim bok1 As Workbook, bok2 As Workbook
     Set bok2 = Nothing '设置为空
     f_name = Dir(ThisWorkbook.Path & "\" & "*.xls") '获得本文件夹下的工作簿名称
     Do While f_name <> "" And f_name <> ThisWorkbook.Name '不是空并且不是自己
         Set bok1 = Workbooks.Open(ThisWorkbook.Path & "\" & f_name) '打开它
         If bok2 Is Nothing Then 'bok2不是空就
             bok1.Sheets(1).Copy '拷贝打开的文件
             Set bok2 = ActiveWorkbook '激活bok2
             bok2.Sheets(1).Name = Split(bok1.Name, ".")(0) '用打开的文件名命名
         Else
             bok1.Sheets(1).Copy Before:=bok2.Sheets(1) '拷贝打开的文件到新工作表
             bok2.Sheets(1).Name = Split(bok1.Name, ".")(0) ''用打开的文件名命名
         End If
         bok1.Close '关闭打开的文件
         f_name = Dir() ''获得本文件夹下的工作簿名称
     Loop '循环
End Sub
Sub test() '在代码工作簿上合并多工作簿。
     Dim f_name As String, bok1 As Workbook, bok2 As Workbook
     Set bok2 = ThisWorkbook
     f_name = Dir(ThisWorkbook.Path & "\" & "*.xls")
     Do While f_name <> "" And f_name <> ThisWorkbook.Name
         Set bok1 = Workbooks.Open(ThisWorkbook.Path & "\" & f_name)
             bok1.Sheets(1).Copy Before:=bok2.Sheets(1)
             bok2.Sheets(1).Name = Mid(Split(bok1.Name, ".")(0), 6)
         bok1.Close
         f_name = Dir()
     Loop
End Sub

yzyyyyyyy

再次求助，

蓝桥玄霜

1. Sub lqxs()
   
2.     Dim Arr, Sht As Worksheet, filenm$
   
3.     Dim wb As Workbook, d, i&
   
4.     Application.ScreenUpdating = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set wb = ActiveWorkbook
   
7.     For Each Sht In Sheets
   
8.         d(Sht.Name) = ""
   
9.     Next
   
10.     With Application.FileDialog(msoFileDialogOpen)
    
11.         .AllowMultiSelect = True
    
12.         .Show
    
13.     For i = 1 To .SelectedItems.Count
    
14.         filenm = .SelectedItems(i)
    
15.         With GetObject(filenm)
    
16.             For Each Sht In .Sheets
    
17.                 If d.exists(Sht.Name) Then
    
18.                     Arr = Sht.UsedRange
    
19.                     If IsArray(Arr) Then
    
20.                         Sheets(Sht.Name).[a1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr
    
21.                     Else
    
22.                         Sheets(Sht.Name).[a1] = Arr
    
23.                     End If
    
24.                 End If
    
25.             Next
    
26.             .Close False
    
27.         End With
    
28.         wb.Close True
    
29.     Next
    
30.     End With
    
31.     Application.ScreenUpdating = True
    
32. End Sub
    

复制代码

蓝桥玄霜

请见附件。