[已解决]麻烦大师帮忙修改一下代码谢谢了

Erma

如附件 批量生成文件附件.rar (18.13 KB, 下载次数: 12)

2013-8-23 14:45 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

djyjysxxs

2013-8-23 15:55

红色部份为修改的，其余全为你原有代码
Sub 生成工作簿()
    Dim arr As Variant, tempArr() As Variant, i&, theI&, k&
    Dim theColumnsCount&, theCount&, theWbCounts As Variant, theWb As Workbook
    Dim theDir$, theNumStr$
    theDir = ThisWorkbook.Path
    If Right(theDir, 1) <> "\" Then theDir = theDir & "\"
    theWbCounts = ActiveSheet.Cells(1, 7)
    If theWbCounts <> "" Then
        If IsNumeric(theWbCounts) Then
            If Int(theWbCounts) <> Abs(theWbCounts) Or theWbCounts <= 0 Then
                MsgBox "“G1”单元格指定的待生成的工作簿数目有误！", vbCritical, "错误"
                GoTo The_Exit
            End If
        Else
            MsgBox "“G1”单元格指定的待生成的工作簿数目有误！", vbCritical, "错误"
            GoTo The_Exit
        End If
    Else
        MsgBox "“G1”单元格未指定待生成的工作簿数目！", vbExclamation, "错误"
        GoTo The_Exit
    End If
    arr = ActiveSheet.Cells(1).CurrentRegion
    theColumnsCount = UBound(arr, 2)
    ReDim tempArr(1 To 1, 1 To theColumnsCount)
    Randomize
    MsgBox "警告：目标工作簿将被覆盖！" _
    & vbNewLine & vbNewLine & "生成工作簿需要较长时间，具体视工作簿数目及记录数量而定" _
    & vbNewLine & vbNewLine & "您可通过观察状态栏了解当前进度", vbInformation, "提示"
    DoEvents
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .DisplayStatusBar = True
        .ShowWindowsInTaskbar = False
        SuDir$ = Dir(theDir, vbDirectory)
        Do While SuDir <> ""
        If InStr(SuDir, ".") < 1 Then
        theCount = 0
        Do
            DoEvents
            .StatusBar = "共计 " & theWbCounts & " 个工作簿待生成，当前正在生成第 " & theCount + 1 & " 个工作簿"
            For i = 1 To UBound(arr)
                theI = 1 + Int(Rnd * UBound(arr))
                For k = 1 To theColumnsCount
                    tempArr(1, k) = arr(i, k)
                Next k
                For k = 1 To theColumnsCount
                    arr(i, k) = arr(theI, k)
                Next k
                For k = 1 To theColumnsCount
                    arr(theI, k) = tempArr(1, k)
                Next k
            Next i
            Set theWb = Workbooks.Add
            theCount = theCount + 1
            With theWb
                .Worksheets(1).Cells(1).Resize(UBound(arr), theColumnsCount) = arr
                theNumStr = Format(theCount, "#00")
                .SaveAs theDir & SuDir & "\" & theNumStr & ".xlsx"
                .Close SaveChanges:=False
            End With
        Loop Until theCount = theWbCounts
        End If
        SuDir = Dir
        Loop
        .ShowWindowsInTaskbar = True
        .StatusBar = False
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
The_Exit:
    Set theWb = Nothing
End Sub

跳转到最佳答案楼层

djyjysxxs

红色部份为修改的，其余全为你原有代码
Sub 生成工作簿()
    Dim arr As Variant, tempArr() As Variant, i&, theI&, k&
    Dim theColumnsCount&, theCount&, theWbCounts As Variant, theWb As Workbook
    Dim theDir$, theNumStr$
    theDir = ThisWorkbook.Path
    If Right(theDir, 1) <> "\" Then theDir = theDir & "\"
    theWbCounts = ActiveSheet.Cells(1, 7)
    If theWbCounts <> "" Then
        If IsNumeric(theWbCounts) Then
            If Int(theWbCounts) <> Abs(theWbCounts) Or theWbCounts <= 0 Then
                MsgBox "“G1”单元格指定的待生成的工作簿数目有误！", vbCritical, "错误"
                GoTo The_Exit
            End If
        Else
            MsgBox "“G1”单元格指定的待生成的工作簿数目有误！", vbCritical, "错误"
            GoTo The_Exit
        End If
    Else
        MsgBox "“G1”单元格未指定待生成的工作簿数目！", vbExclamation, "错误"
        GoTo The_Exit
    End If
    arr = ActiveSheet.Cells(1).CurrentRegion
    theColumnsCount = UBound(arr, 2)
    ReDim tempArr(1 To 1, 1 To theColumnsCount)
    Randomize
    MsgBox "警告：目标工作簿将被覆盖！" _
    & vbNewLine & vbNewLine & "生成工作簿需要较长时间，具体视工作簿数目及记录数量而定" _
    & vbNewLine & vbNewLine & "您可通过观察状态栏了解当前进度", vbInformation, "提示"
    DoEvents
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .DisplayStatusBar = True
        .ShowWindowsInTaskbar = False
        SuDir$ = Dir(theDir, vbDirectory)
        Do While SuDir <> ""
        If InStr(SuDir, ".") < 1 Then
        theCount = 0
        Do
            DoEvents
            .StatusBar = "共计 " & theWbCounts & " 个工作簿待生成，当前正在生成第 " & theCount + 1 & " 个工作簿"
            For i = 1 To UBound(arr)
                theI = 1 + Int(Rnd * UBound(arr))
                For k = 1 To theColumnsCount
                    tempArr(1, k) = arr(i, k)
                Next k
                For k = 1 To theColumnsCount
                    arr(i, k) = arr(theI, k)
                Next k
                For k = 1 To theColumnsCount
                    arr(theI, k) = tempArr(1, k)
                Next k
            Next i
            Set theWb = Workbooks.Add
            theCount = theCount + 1
            With theWb
                .Worksheets(1).Cells(1).Resize(UBound(arr), theColumnsCount) = arr
                theNumStr = Format(theCount, "#00")
                .SaveAs theDir & SuDir & "\" & theNumStr & ".xlsx"
                .Close SaveChanges:=False
            End With
        Loop Until theCount = theWbCounts
        End If
        SuDir = Dir
        Loop
        .ShowWindowsInTaskbar = True
        .StatusBar = False
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
The_Exit:
    Set theWb = Nothing
End Sub

Erma

djyjysxxs 发表于 2013-8-23 15:55
红色部份为修改的，其余全为你原有代码
Sub 生成工作簿()
    Dim arr As Variant, tempArr() As Varian ...

老师您好，谢谢帮助。我把代码输入一楼的附件中，执行了一下，即报错了。如图：






不知哪个环节出了错，麻烦您看看。

上清宫主

附件下下来解压到硬盘中，代码复制进去就运行，到是生成了文件，3*49个，太慢了，秒多钟一个

Erma

上清宫主 发表于 2013-8-23 21:46
附件下下来解压到硬盘中，代码复制进去就运行，到是生成了文件，3*49个，太慢了，秒多钟一个

老师你好，我在多台电脑中运行，都会报错，怪事了。我又试了先把附件下载，然后把写的代码复制进去，执行后马上就报错了。不知为什么。

Erma

djyjysxxs 发表于 2013-8-23 15:55
红色部份为修改的，其余全为你原有代码
Sub 生成工作簿()
    Dim arr As Variant, tempArr() As Varian ...

老师您好，我把您写的代码复制进去的时候，以下三行代码会自动变成红色，不知是不是这里的问题？

MsgBox "“G1”单元格指定的待生成的工作簿数目有误！", vbCritical, "错误"

MsgBox "“G1”单元格指定的待生成的工作簿数目有误！", vbCritical, "错误"

MsgBox "“G1”单元格未指定待生成的工作簿数目！", vbExclamation, "错误"

上清宫主

Erma 发表于 2013-8-23 22:02
老师您好，我把您写的代码复制进去的时候，以下三行代码会自动变成红色，不知是不是这里的问题？

tmp.rar (17.42 KB, 下载次数: 5)

2013-8-23 22:10 上传

点击文件名下载附件 帮你组合在一起了，点一下看呢