求助诊断多工作簿合并与工作簿拆分代码问题

Justin-2016

abc123281 发表于 2018-8-19 16:13
Set wb = CreateObject(strPath & strName)
Set wb = GetObject(strPath & strName)

谢谢帮助，感谢耐心讲解，谢谢！

Justin-2016

lsc900707 发表于 2018-8-19 15:59
多工作簿合并的：
Sub test()
    Dim brr(1 To 100000, 1 To 7)

Sub 工作簿拆分()
        Dim arr, d As New Dictionary, i%
        arr = Sheet1.UsedRange
        Application.ScreenUpdating = False
        For i = 2 To UBound(arr)
                d(arr(i, 2)) = ""
        Next i
        Dim wb As Workbook, brr(1 To 20, 1 To 7), j%, k%, fileName$
        For j = 0 To d.Count - 1
                Erase brr()
                brr(1, 1) = "日期": brr(1, 2) = "入库数量": brr(1, 3) = "出库数量": brr(1, 4) = "单价": brr(1, 5) = "入库金额": brr(1, 6) = "出库金额": brr(1, 7) = "备注"
                k = 1
                For i = 2 To UBound(arr)
                        If arr(i, 2) = d.Keys()(j) Then
                                k = k + 1
                                brr(k, 1) = arr(i, 1)
                                brr(k, 2) = arr(i, 2)
                                brr(k, 3) = arr(i, 3)
                                brr(k, 4) = arr(i, 4)
                                brr(k, 5) = arr(i, 5)
                                brr(k, 6) = arr(i, 6)
                                brr(k, 7) = arr(i, 7)
                        End If
                Next i
     fileName = ThisWorkbook.Path & "\" & d.Keys()(j) & ".xlsx"
     If FileExists(fileName) Then Kill fileName
     Set wb = Workbooks.Add
     With wb
        .Worksheets(1).Range("a1").Resize(k, 3) = brr
        .Worksheets(1).Range("a:a").numberformatloca = "yyy/m/d"
        .SaveAs fileName
        .Close
     End With
     Next j
     MsgBox "拆分完成！"
End Sub
Function FileExists(FullName As String) As Boolean
        Dim strNname As String
        strName = Dir(FullName)
        If Len(strName) > 0 Then
                FileExists = True
        Else
                FileExists = False
        End If
End Function

请大神帮忙把这个对应的拆分代码诊断下，看到底问题出在哪里，谢谢！

Justin-2016

chxw68 发表于 2018-8-19 15:45
看了下代码，其中问题比较多。

里面还有个工作簿拆分代码也有问题，请大神帮忙优化下，谢谢！

chxw68

Justin-2016 发表于 2018-8-19 17:01
里面还有个工作簿拆分代码也有问题，请大神帮忙优化下，谢谢！

代码问题太多就不值得修改了，还不如重新写呢。

Justin-2016

chxw68 发表于 2018-8-19 17:28
代码问题太多就不值得修改了，还不如重新写呢。

那麻烦大神帮忙写个代码，我今天评分用完了，明天再补评，谢谢！

chxw68

Justin-2016 发表于 2018-8-19 17:45
那麻烦大神帮忙写个代码，我今天评分用完了，明天再补评，谢谢！

你如果是为了工作可以帮你写一个，如果是为了学习论坛上有很多的例子你搜一下。

Justin-2016

chxw68 发表于 2018-8-19 17:58
你如果是为了工作可以帮你写一个，如果是为了学习论坛上有很多的例子你搜一下。

我是为了工作，跪求大神帮忙写一个，谢谢！

lsc900707

Justin-2016 发表于 2018-8-19 16:41
Sub 工作簿拆分()
        Dim arr, d As New Dictionary, i%
        arr = Sheet1.UsedRange

你要拆分哪个工作表？拆分的依据是什么，你得说清楚呀？

lsc900707

Justin-2016 发表于 2018-8-19 16:41
Sub 工作簿拆分()
        Dim arr, d As New Dictionary, i%
        arr = Sheet1.UsedRange

在同目录下先建立一个“按月拆分”的文件夹，运行代码：
Sub 按月拆分()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = [a1].CurrentRegion
    n = UBound(arr, 2)
    Set rng = [a1].Resize(1, n)
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        s = Month(arr(i, 1))
         If Not d.Exists(s) Then
                Set d(s) = Cells(i, 1).Resize(1, n)
            Else
                Set d(s) = Union(d(s), Cells(i, 1).Resize(1, n))
         End If
    Next
    k = d.Keys
    t = d.Items
    For i = 0 To d.Count - 1
        Set wb = Workbooks.Add(xlWBATWorksheet)
        With wb.Sheets(1)
            rng.Copy .[a1]: t(i).Copy .[a2]
            For j = 1 To UBound(arr, 2)
               .Columns(j).ColumnWidth = ThisWorkbook.ActiveSheet.Columns(j).ColumnWidth
            Next
        End With
        wb.SaveAs fileName:=ThisWorkbook.Path & "\按月拆分\" & k(i) & "月"
        wb.Close
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub

lsc900707

Justin-2016 发表于 2018-8-19 16:41
Sub 工作簿拆分()
        Dim arr, d As New Dictionary, i%
        arr = Sheet1.UsedRange

代码需要审核，附件供参考：