一个EXECL生成几百个EXECL或将几百个EXECL合并成一个EXECL

 最近常用VBA帮同事做些特殊工作
比如经常遇到将一个EXECL生成几百个EXECL
或者将几百个EXECL合并成一个EXECL
以下是详细代码

execl 将多个工作本合成一个

用的时候把sheet4改名为"合并",插入一个标准模块,贴入以下代码:

 

Sub 合并工作表()
Dim i As Integer, j As Integer, k As Integer
For k = 1 To Sheets.Count
If Sheets(k).Name <> "合并" Then
        i = Sheets(k).Range("A65536").End(xlUp).Row
        j = Sheets("合并").Range("A65536").End(xlUp).Row + 1
        Sheets(k).Range("A2:L" & i).Copy Sheets("合并").Cells(j, 1)
End If
Next k
End Sub
在工作表中按alt+F8,运行合并工作表宏就可.

 

将一个EXECL生成几百个EXECL
Sub m()
f "Sheet1"
End Sub
Private Function f(st As String) As Boolean
Dim i, j, k As Integer
Dim wb As String
wb = ActiveWorkbook.Name
For i = 1 To 1
Sheets.Add.Name = "MyExcel" & i
j = 30000 * i - 29999
k = 20000 * i
Sheets(st).Select
Range(Cells(j, 1),
Cells(k,
100)).Select
'这里修改区域，我只引用了第一列的数据（从j行到k行的第一列数据）
Selection.Copy Sheets(("MyExcel" & i)).Select
Range("A1").Select
ActiveSheet.Paste
Next i
Application.DisplayAlerts = False
Dim XSheet As Worksheet
For Each XSheet In Workbooks(wb).Sheets
XSheet.Copy
ActiveWorkbook.SaveAs
Filename:=ThisWorkbook.Path & "/" & ActiveSheet.Name & ".xls"
ActiveWindow.Close
Next
Application.ScreenUpdating = True
Workbooks(wb).Activate
For i = 1 To 1
Sheets(("MyExcel" & i)).Delete
Next i
Kill
ThisWorkbook.Path & "/" & st & ".xls"
End
Function
 

 

补充：

最近遇到第一行、第二行 是空的情况，无法复制。修改代码如下：

Sub 合并工作表2()
    Dim Sht As Worksheet
    Dim i As Long
    On Error Resume Next
    Sheets("合并").Move before:=Sheets(1)
    If Err.Number = 9 Then
        Sheets.Add(before:=Sheets(1)).Name = "合并"
    Else

    End If
   
    For Each Sht In Sheets
        If Sht.Name <> "合并" Then
            i = Sht.Range("B65536").End(xlUp).Row
            Sht.Range("B3:L" & i).Copy Sheets("合并").Range("B65536").End(xlUp).Offset(1, 0)
        End If
    Next
   
End Sub