[已解决]关于工作薄分解代码出错求助？

nancy66317

   今天看一个关于工作薄分解的代码时，总是提示出错，但怎么也找不到原因，请各位路过的大侠帮忙看一下，谢谢！ 分解工作薄.rar (12.25 KB, 下载次数: 13)

2013-8-22 11:18 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

爱疯

2013-8-23 11:08

Sub 分表()
    Dim Pat As String, M As String, Bm As Workbook
    Dim H As Long, H1 As Long, Sa As Long
    Dim Arr As Variant
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    c = Application.InputBox(Prompt:="请输入目标参照列数字：", Type:=1)
    Pat = ThisWorkbook.Path & "\"
    With Sheet1
        H = .Range("A65536").End(xlUp).Row
        For H1 = 2 To H
            If M = "" Then M = Cells(H1, c)   '记录要生成的工作薄 名称
            If Cells(H1, c) = M Then
                If Sa = 0 Then Sa = H1    '记录起 始位置
                If Cells(H1 + 1, c) <> M Then
                    .Range("a1").CurrentRegion.Copy
                    Set Bm = Workbooks.Add(1)   '新建一个工作薄,且只有一个工作表
                    Range("a1").PasteSpecial Paste:=xlPasteFormats
                    Bm.SaveAs Pat & M   '新建的工作薄 命名另存
                    With Bm.Sheets(1).Range("A1")
                        .Resize(, 7).Value = Sheet1.Range("A1:G1").Value    '写入表头
                        .Offset(1).Resize(H1 - Sa + 1, 7) = Sheet1.Range(Sheet1.Cells(Sa, "A"), Sheet1.Cells(H1, "G")).Value
                        '写入数据
                    End With
                    Range("a1").CurrentRegion.EntireColumn.AutoFit
                    Bm.Close True   '关闭这个新建的工作薄
                    M = ""    '清空 表名
                    Sa = 0    '清空 起始位置
                End If
            End If
        Next
    End With
    Application.ScreenUpdating = True
    MsgBox "工作薄已生成,并已保存到 " & Pat & " 文件夹中", , "完成"
End Sub

跳转到最佳答案楼层

nancy66317

Sub 分表()

Dim Pat As String, M As String, Bm As Workbook

Dim H As Long, H1 As Long, Sa As Long

c = Application.InputBox(Prompt:="请输入目标参照列数字：", Type:=1)

Dim Arr As Variant

  Application.ScreenUpdating = False

  Pat = ThisWorkbook.Path & "\"

  With Sheet1

    H = .Range("A65536").End(xlUp).Row

    For H1 = 2 To H

      If M = "" Then M = Cells(H1, c)   '记录要生成的工作薄 名称

      If Cells(H1, c) = M Then

        If Sa = 0 Then Sa = H1    '记录起 始位置

        If Cells(H1 + c, 1) <> M Then

          Set Bm = Workbooks.Add(1)   '新建一个工作薄,且只有一个工作表

          Bm.SaveAs Pat & M   '新建的工作薄 命名另存

          With Bm.Sheets(1).Range("A1")

            .Resize(, 7).Value = Sheet1.Range("A1:G1").Value    '写入表头

            .Offset(1).Resize(H1 - Sa, 7) = Sheet1.Range(Sheet1.Cells(Sa, "A"), Sheet1.Cells(H1, "G")).Value

            '写入数据

          End With

          Bm.Close True   '关闭这个新建的工作薄

          M = ""    '清空 表名

          Sa = 0    '清空 起始位置

        End If

      End If

    Next

  End With

  Application.ScreenUpdating = True

  MsgBox "工作薄已生成,并已保存到 " & Pat & " 文件夹中", , "完成"

End Sub

nancy66317

代码是打开表格，按F11进入模版1就能看到！

我心飞翔410

最好再说哈你要做什么 达到什么效果

nancy66317

把一个表，按某列，如此表，按品牌（第4列）分解成多个工作薄

爱疯

Sub 分表()
    Dim Pat As String, M As String, Bm As Workbook
    Dim H As Long, H1 As Long, Sa As Long
   
    c = Application.InputBox(Prompt:="请输入目标参照列数字：", Type:=1)
    Dim Arr As Variant
    Application.ScreenUpdating = False
    Pat = ThisWorkbook.Path & "\"
    With Sheet1
        H = .Range("A65536").End(xlUp).Row
        For H1 = 2 To H
            If M = "" Then M = Cells(H1, c)   '记录要生成的工作薄 名称
            If Cells(H1, c) = M Then
                If Sa = 0 Then Sa = H1    '记录起 始位置
                If Cells(H1+1, c) <> M Then
                    Set Bm = Workbooks.Add(1)   '新建一个工作薄,且只有一个工作表
                    Bm.SaveAs Pat & M   '新建的工作薄 命名另存
                    With Bm.Sheets(1).Range("A1")
                        .Resize(, 7).Value = Sheet1.Range("A1:G1").Value    '写入表头
                        .Offset(1).Resize(H1 - Sa+1, 7) = Sheet1.Range(Sheet1.Cells(Sa, "A"), Sheet1.Cells(H1, "G")).Value
                        '写入数据
                    End With
                    Bm.Close True   '关闭这个新建的工作薄
                    M = ""    '清空 表名
                    Sa = 0    '清空 起始位置
                End If
            End If
        Next
    End With
    Application.ScreenUpdating = True
    MsgBox "工作薄已生成,并已保存到 " & Pat & " 文件夹中", , "完成"
End Sub

是要改成这样吗

nancy66317

爱疯 发表于 2013-8-22 11:33
Sub 分表()
    Dim Pat As String, M As String, Bm As Workbook
    Dim H As Long, H1 As Long, Sa As ...

为什么这里写成.Offset(1).Resize(H1 - Sa + 1, 7)和.Offset(1).Resize(H1 - Sa , 7)结果是一样的呢？

爱疯

nancy66317 发表于 2013-8-23 09:16
为什么这里写成.Offset(1).Resize(H1 - Sa + 1, 7)和.Offset(1).Resize(H1 - Sa , 7)结果是一样的呢？

.Offset(1).Resize(H1 - Sa + 1, 7)
对

.Offset(1).Resize(H1 - Sa , 7)结果是一样的呢？
不对，少了本次划分中的最后1个。

nancy66317

爱疯 发表于 2013-8-23 09:40
.Offset(1).Resize(H1 - Sa + 1, 7)
对

但是还有一个问题，分解后日期显示不正常（变为数字了），另外第二列显示也不完整，能不能不改变格式粘贴呢？

爱疯

Sub 分表()
    Dim Pat As String, M As String, Bm As Workbook
    Dim H As Long, H1 As Long, Sa As Long
   
    c = Application.InputBox(Prompt:="请输入目标参照列数字：", Type:=1)
    Dim Arr As Variant
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Pat = ThisWorkbook.Path & "\"
    With Sheet1
        H = .Range("A65536").End(xlUp).Row
        For H1 = 2 To H
            If M = "" Then M = Cells(H1, c)   '记录要生成的工作薄 名称
            If Cells(H1, c) = M Then
                If Sa = 0 Then Sa = H1    '记录起 始位置
                If Cells(H1 + 1, c) <> M Then
                    Set Bm = Workbooks.Add(1)   '新建一个工作薄,且只有一个工作表
                    Range("b:b").NumberFormat = "@"
                    Bm.SaveAs Pat & M   '新建的工作薄 命名另存
                    With Bm.Sheets(1).Range("A1")
                        .Resize(, 7).Value = Sheet1.Range("A1:G1").Value    '写入表头
                        .Offset(1).Resize(H1 - Sa + 1, 7) = Sheet1.Range(Sheet1.Cells(Sa, "A"), Sheet1.Cells(H1, "G")).Value
                        '写入数据
                    End With
                    Range("a1").CurrentRegion.EntireColumn.AutoFit
                    Bm.Close True   '关闭这个新建的工作薄
                    M = ""    '清空 表名
                    Sa = 0    '清空 起始位置
                End If
            End If
        Next
    End With
    Application.ScreenUpdating = True
    MsgBox "工作薄已生成,并已保存到 " & Pat & " 文件夹中", , "完成"
End Sub