[已解决]合并多个工作薄后发现顺序不对，请教达人

FVOOL

有诺干个工作薄（1.xls、2.xls……），合并后发现：在工作薄小于10个时工作正常，但10个以上时合并的顺序变了（1.xls、10.xls、11.xls……2.xls、3.xls……9.xls)，这是怎回事，我想按名称从小到大的顺序一次合并到表格的两列中，使用的代码是：
Sub 合并工作簿()
Application.DisplayAlerts = False '关闭提示窗口
shes = Application.SheetsInNewWorkbook '工作簿中包含工作表数
Application.SheetsInNewWorkbook = 1 '生成的新工作簿中只有一个工作表
Set newbok = Workbooks.Add '生成新工作簿
Set newshe = newbok.Worksheets(1) '新工作表
s = 1 '从新工作表的第一行写入数据
n = Dir("d:\123\*.xls") '需要合并的所有工作表都要事先保存在D盘123文件夹下
Do While n <> ""
Set wb = Application.Workbooks.Open("d:\123\" & n)
    Rows("1:2").Select
    Selection.Delete Shift:=xlUp'删除行
    Columns("A:C").Select
    Selection.Delete Shift:=xlToLeft'删除列   
     Columns("FM:FM").Select
    Selection.Delete Shift:=xlToLeft'删除列   
   wb.Worksheets(1).UsedRange.Copy '复制数据
newbok.Activate
Cells(s, 1).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True'转置为列
    Selection.Copy
   Cells(s, 1).Select
ActiveSheet.Paste '执行粘贴
s = newshe.UsedRange.Rows.Count
Cells(s, 3) = wb.Name '写入数据所属的工作簿名字
s = s + 1
wb.Close '关闭工作簿
n = Dir() '取下一个工作簿
Loop
Application.SheetsInNewWorkbook = shes
Application.DisplayAlerts = True
Range("a1").Select
End Sub
请达人帮助

最佳答案

月排行榜 / 总排行榜

zjdh

2013-9-12 09:56

FVOOL 发表于 2013-9-12 08:32
谢谢了，用方法1已经能解决了，但已有的文件太多，改名太麻烦了，我也想到循环
提供文件名的方法，可实在 ...

改一个头一个尾即可
Sub 合并工作簿()
    Application.DisplayAlerts = False    '关闭提示窗口
    shes = Application.SheetsInNewWorkbook    '工作簿中包含工作表数
    Application.SheetsInNewWorkbook = 1    '生成的新工作簿中只有一个工作表
    Set newbok = Workbooks.Add    '生成新工作簿
    Set newshe = newbok.Worksheets(1)    '新工作表
    s=1
    For I = 1 To 300   '设定至大于最大文件编号
        If Dir("d:\123\" & I & ".xls") <> "" Then      '需要合并的所有工作表都要事先保存在D盘123文件夹下
            Set wb = Application.Workbooks.Open("d:\123\" & I & ".xls")
            Rows("1:2").Select
            Selection.Delete Shift:=xlUp    '删除行
            Columns("A:C").Select
            Selection.Delete Shift:=xlToLeft    '删除列
            Columns("FM:FM").Select
            Selection.Delete Shift:=xlToLeft    '删除列
            wb.Worksheets(1).UsedRange.Copy    '复制数据
            newbok.Activate
            Cells(s, 1).Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                             False, Transpose:=True    '转置为列
            Selection.Copy
            Cells(s, 1).Select
            ActiveSheet.Paste    '执行粘贴
            s = newshe.UsedRange.Rows.Count+1
            Cells(s, 3) = wb.Name    '写入数据所属的工作簿名字
            wb.Close    '关闭工作簿
        End If
    Next
    Application.SheetsInNewWorkbook = shes
    Application.DisplayAlerts = True
    Range("a1").Select
End Sub

跳转到最佳答案楼层

zjdh

方法：
1. 将文件名改为01、02、03....
2. 或用循环提供文件名，打开汇总。

FVOOL

zjdh 发表于 2013-9-12 07:36
方法：
1. 将文件名改为01、02、03....
2. 或用循环提供文件名，打开汇总。

谢谢了，用方法1已经能解决了，但已有的文件太多，改名太麻烦了，我也想到循环
提供文件名的方法，可实在弄不了，能不能提供下方法2的代码，将深表感谢。

hwc2ycy

你在用DIR搜索的时候，是按文件名的顺序来的，这个没有办法的。

要改名，你也可以用代码来改，手工改，多的话确实不方便。

反正用代码能生成文件清单，你在下拉生成序号就很容易的。

zjdh

FVOOL 发表于 2013-9-12 08:32
谢谢了，用方法1已经能解决了，但已有的文件太多，改名太麻烦了，我也想到循环
提供文件名的方法，可实在 ...

改一个头一个尾即可
Sub 合并工作簿()
    Application.DisplayAlerts = False    '关闭提示窗口
    shes = Application.SheetsInNewWorkbook    '工作簿中包含工作表数
    Application.SheetsInNewWorkbook = 1    '生成的新工作簿中只有一个工作表
    Set newbok = Workbooks.Add    '生成新工作簿
    Set newshe = newbok.Worksheets(1)    '新工作表
    s=1
    For I = 1 To 300   '设定至大于最大文件编号
        If Dir("d:\123\" & I & ".xls") <> "" Then      '需要合并的所有工作表都要事先保存在D盘123文件夹下
            Set wb = Application.Workbooks.Open("d:\123\" & I & ".xls")
            Rows("1:2").Select
            Selection.Delete Shift:=xlUp    '删除行
            Columns("A:C").Select
            Selection.Delete Shift:=xlToLeft    '删除列
            Columns("FM:FM").Select
            Selection.Delete Shift:=xlToLeft    '删除列
            wb.Worksheets(1).UsedRange.Copy    '复制数据
            newbok.Activate
            Cells(s, 1).Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                             False, Transpose:=True    '转置为列
            Selection.Copy
            Cells(s, 1).Select
            ActiveSheet.Paste    '执行粘贴
            s = newshe.UsedRange.Rows.Count+1
            Cells(s, 3) = wb.Name    '写入数据所属的工作簿名字
            wb.Close    '关闭工作簿
        End If
    Next
    Application.SheetsInNewWorkbook = shes
    Application.DisplayAlerts = True
    Range("a1").Select
End Sub