实用vba案例

拆分sheet

每个sheet存到一个新文件中

Sub chaifen()
   Dim sht As Worksheet
       Dim MyBook As Workbook
       Set MyBook = ActiveWorkbook
       For Each sht In MyBook.Sheets
           sht.Copy
           ActiveWorkbook.SaveAs Filename:=MyBook.Path & "\" & MyBook.Name & "_" & sht.Name & ".xls"
           ActiveWorkbook.Close
       Next
       MsgBox "文件已经被分拆完毕!"
End Sub

拆分行

文件行数太多，按照每20行进行切割，切割后存到新的excel表中。

Sub splitRow()
Application.ScreenUpdating = False
p = ActiveWorkbook.Path & "\"
With ActiveSheet
    For r = 1 To .Range("a1048576").End(xlUp).Row Step 20
        Set wb = Workbooks.Add
        .Rows(r).Resize(30).Copy wb.Sheets(1).Cells(1)
        wb.SaveAs p & r & ".xls", xlNormal
        wb.Close
    Next
End With
Application.ScreenUpdating = True
End Sub

根据单元格创建sheet

循环目标区域，如果对应名字的sheet已经有了，就不创建，否则创建对应的sheet

Sub process()
Dim sht As Worksheet
Dim i, k As Integer
For Each rag In Range("d2:d1000")
    k = 0
    For Each sht In Sheets
        If rag.Value = sht.Name Then
            k = 1
            Exit For
        End If
    Next
    If k = 0 Then
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = rag
    End If
Next
End Sub

目标区域复制到其他sheet

Sub copytosheet()
For i = 2 To Sheets.Count
    Sheets(1).Range("a1").Copy Sheets(i).Range("a1")
Next
End Sub

对整个文件夹内的所有文件处理

下面的案例，扫描目标文件夹内所有的xlsx文件，然后执行processEach过程。
processEach过程会打开这个文件，对文件执行mysplit，然后保存关闭。
mysplit过程会把文件拆开，放到文件所在位置的子文件夹内。

整个代码的作用：
把strPath下的所有xlsx文件切割，切割的规则是每30行切一次。切割出来的文件放在全部strPath/target下。

Sub ListFiles()
    Dim strPath As String, strTmp As String
    Dim originbook As Workbook
    strPath = "C:\test\"
    strTmp = Dir(strPath & "*.xlsx")
    i = 1
    Do While strTmp <> ""
        Call processEach(strPath, strTmp) 
        strTmp = Dir
        i = i + 1
    Loop
End Sub

Sub processEach(filepath As String, filename As String)
Workbooks.Open filepath & filename
With ActiveSheet
    Call mysplit(30)
End With
Workbooks(filename).Save
Workbooks(filename).Close
End Sub

Sub mysplit(m As Integer)
Application.ScreenUpdating = False
p = ActiveWorkbook.Path & "\target\"
On Error Resume Next
VBA.MkDir p
fn = ActiveWorkbook.Name
With ActiveSheet
    For r = 1 To .Range("a1048576").End(xlUp).Row Step m
        Set wb = Workbooks.Add
        .Rows(r).Resize(m).Copy wb.Sheets(1).Cells(1)
        wb.SaveAs p & fn & "_" & r & ".xlsx"
        wb.Close
    Next
End With
Application.ScreenUpdating = True
End Sub