[已解决]求助各位老师，这个表格怎么通过vba编程实现，谢谢~~

zhen1990

我想将sheet2的每一条信息都分别填到sheet1对应的表格里，然后以姓名为文件名保存到一个文件夹里，最后这个文件夹里会有好多以姓名命名的工作表，请问各位老师能做到吗？

最佳答案

月排行榜 / 总排行榜

风林火山

2014-1-16 13:44

Sub test()
    Dim arr, wk As Workbook, wkpath$, k%, i%
    wkpath = ThisWorkbook.Path & "/"
    arr = Range("a1:e" & Cells(Rows.Count, 1).End(3).Row)
    Application.ScreenUpdating = False
    For k = 2 To UBound(arr)
        ThisWorkbook.Activate
        Sheet2.Activate
        For i = 1 To UBound(arr, 2)
            Sheet1.Cells(4, i) = arr(k, i)
        Next i
        ThisWorkbook.Sheets("Sheet1").Copy
        ActiveWorkbook.SaveAs wkpath & Sheet1.Cells(4, 1)
        ActiveWindow.Close
    Next k
    Sheet1.Rows(4) = ""
    Application.ScreenUpdating = True
    MsgBox "拆分工作薄成功,共" & k - 2 & "个工作薄，存放在" & wkpath & "目录下"
End Sub

跳转到最佳答案楼层

风林火山

Sub test()
    Dim arr, wk As Workbook, wkpath$, k%, i%
    wkpath = ThisWorkbook.Path & "/"
    arr = Range("a1:e" & Cells(Rows.Count, 1).End(3).Row)
    Application.ScreenUpdating = False
    For k = 2 To UBound(arr)
        ThisWorkbook.Activate
        Sheet2.Activate
        For i = 1 To UBound(arr, 2)
            Sheet1.Cells(4, i) = arr(k, i)
        Next i
        ThisWorkbook.Sheets("Sheet1").Copy
        ActiveWorkbook.SaveAs wkpath & Sheet1.Cells(4, 1)
        ActiveWindow.Close
    Next k
    Sheet1.Rows(4) = ""
    Application.ScreenUpdating = True
    MsgBox "拆分工作薄成功,共" & k - 2 & "个工作薄，存放在" & wkpath & "目录下"
End Sub

zjdh

Sub TEST()
    Application.ScreenUpdating = False
    For I = 2 To Range("A65536").End(3).Row
        Rows(I).Copy
        Sheets(1).Range("A4").PasteSpecial Paste:=xlPasteValues
        Sheets(1).Copy
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Sheets(1).Range("A4") & ".xls"
        ActiveWorkbook.Close
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "分表完毕！"
End Sub
检测结果.rar (11.03 KB, 下载次数: 10)

2014-1-16 14:13 上传

点击文件名下载附件

zhen1990

zjdh 发表于 2014-1-16 14:13
Sub TEST()
    Application.ScreenUpdating = False
    For I = 2 To Range("A65536").End(3).Row

谢谢老师，真的太厉害了，如果我给上面那行单元格再加个单位，怎么修改代码啊？

zhen1990

zjdh 发表于 2014-1-16 14:13
Sub TEST()
    Application.ScreenUpdating = False
    For I = 2 To Range("A65536").End(3).Row

看起来好复杂啊，太厉害了，我想再请教一下，如果上面那行单元格我再加个单位，该怎么修改代码呢?

zhen1990

就是第一个表格有点变化，在那一行上面又加了个单位，您写的代码好复杂，所以只好再来求助咯，请老师再指导指导