如何用<em>vba</em>批量将一个<em>excel</em>文件

Sub SaveSheetAsWorkbook()
Dim theName As String
On Error GoTo Line1
For Each sht In ActiveWindow.SelectedSheets
sht.Copy
theName = ThisWorkbook.Path & ThisWorkbook.Name & "_" & sht.Name & ".xls"
ActiveWorkbook.SaveAs Filename:=theName, FileFormat:=xlNormal
ActiveWindow.Close
Next
Line1:
End Sub

按Alt+F11，打开百VBA编辑器，在度代码窗问口中粘答，最后按F5运行。内即容可！！

打开这个excel ,另存为副本, (最好放到某个文件夹内)
按7a64e4b893e5b19e333alt+F11, 视图---代码窗口 --把如下复制进去--按F5 运行即可

Sub fencun()
Application.ScreenUpdating = False
b = Sheets.Count

For i = b To 1 step -1
sheets(i).select
sheets(i).Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues

Sheets(i).Copy
a = ThisWorkbook.Worksheets(i).Name
With ActiveWorkbook
.SaveAs Filename:=ThisWorkbook.Path & "\" & a & ".xlsx"
.Close

End With
Next i

Application.ScreenUpdating = true

End Sub

试一下这个代码：第3行的bt = 1是指标题行有1行；如果标题行有多行，请更改1为实际行数。

 

将要汇总的文件放到一个单独专门的文件夹中。在此文件夹中新建或打开一个Excel文件作为汇总文件，找一个空白Sheet或者新建一个Sheet存放汇总数据。

然后按“Alt+F11”打开VBA编辑窗口，然后在左侧对应的Sheet上双击，右侧空白处粘贴下面的代码。关闭VBA窗口。然7a686964616fe78988e69d83334后按“Alt+F8”打开宏窗口，选择刚插入的宏，点击“执行”。

 

Sub hz()
Dim bt, i, r, c, n, first As Long
bt = 1
Dim f, ff As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ff = fso.getfolder(ThisWorkbook.Path & "\")
For Each f In ff.Files
    If f.Name <> ThisWorkbook.Name And Left(f.Name, 2) <> "~$" Then
        Workbooks.Open ThisWorkbook.Path & "\" & f.Name
        With Workbooks(f.Name)
            For i = 1 To .Sheets.Count
                If first = 0 Then
                    c = .Sheets(i).Cells(1, Columns.Count).End(xlToLeft).Column
                    .Sheets(i).Range("A1").Resize(bt, c).Copy ThisWorkbook.ActiveSheet.Range("A1")
                    n = bt + 1: first = 1
                End If
                r = .Sheets(i).Cells(Rows.Count, "A").End(xlUp).Row
                .Sheets(i).Range("A" & bt + 1).Resize(r - 1, c).Copy ThisWorkbook.ActiveSheet.Range("A" & n)
                n = n + r - bt
            Next
        End With
        Workbooks(f.Name).Close False
    End If
Next f
Set fso = Nothing
End Sub

答：

Sub Demo()
    Dim Sht As Worksheet
    Dim FilePath As String
    FilePath = ThisWorkbook.Path & "\"
    Application.ScreenUpdating = False
    For Each Sht In ThisWorkbook.Sheets
        If Not Sht.Name = "分析" Then
            With Sht
                .UsedRange.Value = .UsedRange.Value
                .Copy
            End With
            With ActiveWorkbook
                .SaveAs Filename:=FilePath & Sht.Name
                .Close
            End With
        End If
    Next Sht
    Application.ScreenUpdating = True
    MsgBox "导出完成7a64e78988e69d83366"
End Sub