[已解决]请问如何用VBA实现这种效果显著，谢谢。

新一

如附件，总表中B列产品名称与工作表名称相同，则将相应内容复制到相应工作表中，复制要求跟总表的格式一样（比如字体颜色是红色的，复制后，字体也是红色）谢谢。

最佳答案

月排行榜 / 总排行榜

Excel学徒123

2016-11-30 19:48

1. Option Explicit
   
2. 
   
3. Sub SplitSheet()
   
4.     Dim arrRow()
   
5.     Dim lRow&, Ends&
   
6.     Dim iCnt%
   
7.     Dim iarrRow%
   
8.     Dim actSheet As Worksheet
   
9.     Application.ScreenUpdating = False
   
10.     With Worksheets("总表")
    
11.         Ends = .Cells(.Rows.Count, 1).End(3).Row
    
12.         For lRow = 1 To Ends
    
13.             If InStr(.Cells(lRow, 1), "产品型号：") Then
    
14.                 iCnt = iCnt + 1
    
15.                 ReDim Preserve arrRow(1 To iCnt)
    
16.                 arrRow(iCnt) = lRow
    
17.             End If
    
18.         Next
    
19.         For iarrRow = 1 To UBound(arrRow)
    
20.             Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Replace(.Cells(arrRow(iarrRow), 1), "产品型号：", "")
    
21.             Set actSheet = ActiveSheet
    
22.             If iarrRow < UBound(arrRow) Then
    
23.                 .Range(.Cells(arrRow(iarrRow), "A"), .Cells(arrRow(iarrRow + 1), "R")).Copy actSheet.Range("A1")
    
24.             Else
    
25.                 .Range(.Cells(arrRow(iarrRow), "A"), .Cells(Ends, "R")).Copy actSheet.Range("A1")
    
26.             End If
    
27.         Next
    
28.     End With
    
29.     Application.ScreenUpdating = True
    
30. End Sub
    

复制代码

拿去玩吧

跳转到最佳答案楼层

Excel学徒123

1. Option Explicit
   
2. 
   
3. Sub SplitSheet()
   
4.     Dim arrRow()
   
5.     Dim lRow&, Ends&
   
6.     Dim iCnt%
   
7.     Dim iarrRow%
   
8.     Dim actSheet As Worksheet
   
9.     Application.ScreenUpdating = False
   
10.     With Worksheets("总表")
    
11.         Ends = .Cells(.Rows.Count, 1).End(3).Row
    
12.         For lRow = 1 To Ends
    
13.             If InStr(.Cells(lRow, 1), "产品型号：") Then
    
14.                 iCnt = iCnt + 1
    
15.                 ReDim Preserve arrRow(1 To iCnt)
    
16.                 arrRow(iCnt) = lRow
    
17.             End If
    
18.         Next
    
19.         For iarrRow = 1 To UBound(arrRow)
    
20.             Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Replace(.Cells(arrRow(iarrRow), 1), "产品型号：", "")
    
21.             Set actSheet = ActiveSheet
    
22.             If iarrRow < UBound(arrRow) Then
    
23.                 .Range(.Cells(arrRow(iarrRow), "A"), .Cells(arrRow(iarrRow + 1), "R")).Copy actSheet.Range("A1")
    
24.             Else
    
25.                 .Range(.Cells(arrRow(iarrRow), "A"), .Cells(Ends, "R")).Copy actSheet.Range("A1")
    
26.             End If
    
27.         Next
    
28.     End With
    
29.     Application.ScreenUpdating = True
    
30. End Sub
    

复制代码

拿去玩吧

新一

谢谢老师的帮助{:011:}