这个拆分附表的代码哪里出错了

zhong4314

求助各位，我想把附表中的“公司名称”及对应的行内容拆分出各个附表出来，并且各附表的名称以公司名称独立起来，写了下面的代码，但执行时报错，应该怎样修改：


Sub 拆分多个工作表()

    Dim danyuange1 As Range, danyuange2 As Range
   
    Dim fubiao As Worksheet
   
    Dim hangshu
   
    Dim biaogemingcheng As String
   
        hangshu = Worksheets("拆分多个工作表").Rows.Count
        
        Set danyuange2 = Range("A" & hangshu).End(xlUp)
        
            For Each danyuange1 In Range("A3", danyuange2)
            
                For Each fubiao In Worksheets
               
                biaogemingcheng = fubiao.Name
               
                Next fubiao
               
                    If InStr(1, biaogemingcheng, danyuange1.Value) > 0 Then
                 
                    danyuange1.EntireRow.Copy Sheets(danyuange1.Value).Range("A" & hangshu).End(xlUp).Offset(1, 0)
                 
                     Else
                 
                    Worksheets.Add(after:=Sheets(Sheets.Count)).Name = danyuange1.Value
                 
                    Worksheets("拆分多个工作表").Range("A2").EntireRow.Copy [A1]
                 
                    danyuange1.EntireRow.Copy Range("a" & hangshu).End(xlUp).Offset(1, 0)
                 
                    End If
                  
             Next danyuange1
            
    End Sub
               

风林火山

思路正确，但是方法不对。提供一种思路。先确定要生成多少个工作表，然后。。。。

zhong4314

根据附表的公司名称数量，我是想生成3个附表的

zhong4314

风林火山 发表于 2022-12-3 09:21
思路正确，但是方法不对。提供一种思路。先确定要生成多少个工作表，然后。。。。

根据表里公司名称的数量，我是想生成3个附表的

哥儿-

代码要修改话，可以改成这样，但这个拆分工作表的代码效率一般
Sub 拆分工作表()
    Dim rng As Range, endRng As Range, sht As Worksheet
    Dim shtname$, temp As Range
    Set endRng = Sheet8.Cells(Rows.Count, 1).End(3)
    Set temp = Sheet8.Rows(2)
    Application.ScreenUpdating = False
    For Each rng In Sheet8.Range(Cells(3, 1), endRng)
        For Each sht In Sheets
            shtname = shtname & "\" & sht.Name
        Next
        If InStr(shtname, rng.Value) Then
            temp.Copy Sheets(rng.Value).[a1]
            rng.EntireRow.Copy Sheets(rng.Value).Cells(Rows.Count, 1).End(3).Offset(1)
        Else
            Worksheets.Add(after:=Sheets(Sheets.Count)).Name = rng.Value
        End If
        shtname = ""
    Next rng
    Application.ScreenUpdating = True
End Sub

zhong4314

哥儿- 发表于 2022-12-3 12:19
代码要修改话，可以改成这样，但这个拆分工作表的代码效率一般
Sub 拆分工作表()
    Dim rng As Range,  ...

你好，我想问一下为什么执行了代码后，附表“广州*****”的金额好像不太对哦...........

哥儿-

zhong4314 发表于 2022-12-3 18:59
你好，我想问一下为什么执行了代码后，附表“广州*****”的金额好像不太对哦...........

漏写了点代码，光建新表没有复制过去，改过来，你测试一下。
Sub 拆分工作表()
    Dim rng As Range, endRng As Range, sht As Worksheet
    Dim shtname$, temp As Range
    Set endRng = Sheet8.Cells(Rows.Count, 1).End(3)
    Set temp = Sheet8.Rows(2)
    Application.ScreenUpdating = False
    For Each rng In Sheet8.Range(Cells(3, 1), endRng)
        For Each sht In Sheets
            shtname = shtname & "\" & sht.Name
        Next
        If InStr(shtname, rng.Value) Then
            rng.EntireRow.Copy Sheets(rng.Value).Cells(Rows.Count, 1).End(3).Offset(1)
        Else
            Worksheets.Add(after:=Sheets(Sheets.Count)).Name = rng.Value
            temp.Copy Sheets(rng.Value).[a1]
            rng.EntireRow.Copy Sheets(rng.Value).Cells(Rows.Count, 1).End(3).Offset(1)
        End If
        shtname = ""
    Next rng
    Application.ScreenUpdating = True
End Sub

图不安兔

哥儿- 发表于 2022-12-3 19:34
漏写了点代码，光建新表没有复制过去，改过来，你测试一下。
Sub 拆分工作表()
    Dim rng As Range,  ...

哥儿老师：您好！多谢了！

zjdh

在你的代码上稍作修改
Sub 拆分多个工作表()
    Dim danyuange1 As Range, danyuange2 As Range
    Dim fubiao As Worksheet
    Dim hangshu
    Dim biaogemingcheng As String
    hangshu = Worksheets("拆分多个工作表").Rows.Count
    Set danyuange2 = Range("A" & hangshu).End(xlUp)
    For Each danyuange1 In Range("A3", danyuange2)
        For Each fubiao In Worksheets
            biaogemingcheng = fubiao.Name
            If InStr(1, biaogemingcheng, danyuange1.Value) > 0 Then
                danyuange1.EntireRow.Copy Sheets(danyuange1.Value).Range("A" & hangshu).End(xlUp).Offset(1, 0)
                GoTo 10
            End If
        Next fubiao
        Worksheets.Add(after:=Sheets(Sheets.Count)).Name = danyuange1.Value
        Worksheets("拆分多个工作表").Range("A2").EntireRow.Copy [A1]
        danyuange1.EntireRow.Copy Range("a" & hangshu).End(xlUp).Offset(1, 0)
10  Next danyuange1
    MsgBox "拆分完成！"
End Sub

zhong4314

哥儿- 发表于 2022-12-3 19:34
漏写了点代码，光建新表没有复制过去，改过来，你测试一下。
Sub 拆分工作表()
    Dim rng As Range,  ...

谢谢哥儿老师，辛苦了