帮忙修改代码

hotf4zhl

附上代码

Sub test()
  Dim r%, i%, c, aa, ws
  Dim arr, brr
  Dim d As Object
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set d = CreateObject("scripting.dictionary")
  With Worksheets("数据")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    arr = .Range("a1:a" & r)
    For i = 2 To UBound(arr)
      If Not d.exists(arr(i, 1)) Then
        Set d(arr(i, 1)) = Range("a1").Resize(1, c)
      End If
      Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, c))
    Next
  End With
  For Each aa In d.keys
    On Error Resume Next
    Set ws = Worksheets(aa)
    If Err Then
      Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
      ws.Name = aa
    End If
    On Error GoTo 0
    With ws
      d(aa).Copy .Range("a1")
    End With
  Next
  Application.ScreenUpdating = True
End Sub




在“数据”工作表中，第二行广播里有些带函数的公式，例如cell H2, I2,J2。 当这一行数据被复制到“广播”工作表中时会同时将公式复制过去。请问，可不可以只复制数据的数值？类似加个.value之类的?

另外，能不能加一个命令，再形成工作表“广播”，“杂志”时同时清理掉这些工作表中已有的数据？

类似Worksheets(aa).clear？

3190496160

对原贴子中别人的解决方案，直接漠视，不置可否，只是一味开贴，

蓝桥玄霜

    With ws
      d(aa).Copy .Range("a1")
      .[a1].CurrentRegion = .[a1].CurrentRegion.Value  '加一句
    End With

hotf4zhl

蓝桥玄霜 发表于 2020-2-13 13:30
With ws
      d(aa).Copy .Range("a1")
      .[a1].CurrentRegion = .[a1].CurrentRegion.Value  ' ...

d(aa).Copy .Range("a1")
       .[a1].CurrentRegion = .[a1].CurrentRegion.Value

这句不对吧， d(aa).Copy .Range("a1")应该是对工作表重新命名的代码。

hotf4zhl

解决了清理已有工作表内的数据的问题。

现在就是不明白为什么只有第二行数据被复制过去会把公式复制。有没有高手帮忙解答下？

hotf4zhl

自己解决了，多谢大家！

YZC51

3190496160 发表于 2020-2-13 13:21
对原贴子中别人的解决方案，直接漠视，不置可否，只是一味开贴，

非常赞同，好像如此！

chxw68

只复制源数据的值。

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   With Worksheets("数据")
   
9.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
11.     arr = .Range("a1:a" & r)
    
12.     For i = 2 To UBound(arr)
    
13.       If Len(arr(i, 1)) <> 0 Then
    
14.         If Not d.exists(arr(i, 1)) Then
    
15.           Set d(arr(i, 1)) = .Range("a1").Resize(1, c)
    
16.         End If
    
17.         Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, c))
    
18.       End If
    
19.     Next
    
20.   End With
    
21.   For Each aa In d.keys
    
22.     On Error Resume Next
    
23.     Set ws = Worksheets(aa)
    
24.     If Err Then
    
25.       Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
26.       ws.Name = aa
    
27.     End If
    
28.     On Error GoTo 0
    
29.     With ws
    
30.       .Cells.Clear
    
31.       d(aa).Copy
    
32.       .Range("a1").PasteSpecial Paste:=xlPasteValues
    
33.     End With
    
34.   Next
    
35.   Application.ScreenUpdating = True
    
36.   MsgBox "数据拆分完毕！"
    
37. End Sub

复制代码

chxw68

如果问题没有解决，还是尽量在原则中跟贴，不要轻易开新贴，这样既是对在原贴中帮助者的尊重，也便于问题的解决。