http://www.pptjcw.com

excel vba教程:用VBA按列信息拆分数据到多工作簿

    Dim ToWb As Workbook, Sht As Worksheet
    Sub 拆分数据到工作簿()
    Application.ScreenUpdating = False
    Dim ShtName As String, ToRng As Range, i As Integer, DataArr As Variant
    Set Sht = ActiveSheet
    Call ShtAdd ' 调用子过程,新建保存拆分结果的工作表及工作表
    i = 2 '要拆分的第一条数据的行号
    Dim a As Long, b As Long
    Do While Sht.Cells(i, "A").Value ""
    ShtName = Sht.Cells(i, "A").Value
    Set ToRng = ToWb.Worksheets(ShtName).Range("A1048576").End(xlUp).Offset(1, 0)
    DataArr = Sht.Cells(i, "A").Resize(1, 8).Value
    For a = 1 To UBound(DataArr, 1)
    For b = 1 To UBound(DataArr, 2)
    If Len(DataArr(a, b)) > 15 Then
    DataArr(a, b) = "'" & DataArr(a, b)
    End If
    Next b
    Next a
    ToRng.Resize(1, 8).Value = DataArr '用数组传递数据
    i = i + 1 '重设变量的值,以便下次循环能拆分新的记录
    Loop
    Call ShtToWb(ToWb)
    Application.ScreenUpdating = True
    MsgBox "拆分完成!"
    End Sub
    Private Sub ShtToWb(ByVal Wb As Workbook)
    Dim Sht As Worksheet
    For Each Sht In Wb.Worksheets
    Sht.Copy
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Sht.Name & ".xlsx"
    ActiveWorkbook.Close
    Next Sht
    Wb.Close False
    End Sub
    Private Function IsSht(ByVal ShtName As String) As Boolean '判断工作表名称是否存在
    On Error Resume Next
    If Worksheets(ShtName) Is Nothing Then
    IsSht = False '工作表不存在,函数值为False
    Else
    IsSht = True '工作表已存在,函数值为true
    End If
    End Function
    Private Sub ShtAdd()
    Dim ShtCount As Integer '记录新建工作簿中包含的工作表数量
    Set ToWb = Workbooks.Add '新建工作簿,并存到变量ToWb中
    ShtCount = ToWb.Worksheets.Count
    Dim i As Long, ShtName As String
    i = 2
    'Do循环语句用于在工作簿中新建保存拆分结果的工作表
    Do While Sht.Cells(i, "A").Value ""
    ShtName = Sht.Cells(i, "A").Value
    If IsSht(ShtName) = False Then 'IF语句判断指定名称的工作表是否存在
    ToWb.Worksheets.Add after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = ShtName
    Sht.Rows(1).Copy ToWb.Worksheets(ShtName).Rows(1) '复制表头到新工作表中
    End If
    i = i + 1
    Loop
    'For循环语句删除新建的工作簿中原带的空工作表
    Application.DisplayAlerts = False
    For i = ShtCount To 1 Step -1
    ToWb.Worksheets(i).Delete
    Next i
    Application.DisplayAlerts = True
    End Sub

    解决这个问题应该还有其他的思路,给出的示例代码也还有许多需要改进的地方,留给大家自由发挥了。

    提示:如果您觉得本文不错,请点击分享给您的好友!谢谢

    上一篇:excel数据分析:利之星图表,简单漂亮 下一篇:excel教程:《别怕,Excel VBA其实很简单(第3版)》

    郑重声明:本文版权归原作者所有,转载文章仅为传播更多信息之目的,如作者信息标记有误,请第一时间联系我们修改或删除,多谢。