为什么右边数字填充要填充的黄色跑到左边单元格里。

爷们679

为什么右边数字填充要填充的黄色跑到左边单元格里。

liulang0808

1. Sub z()
   
2. 
   
3. 
   
4. 
   
5. 
   
6. Dim ar, b(), M(), d As Object, rng As Range
   
7. Set d = CreateObject("scripting.dictionary")
   
8. ar = [Q1].CurrentRegion.Value
   
9. ReDim b(UBound(ar))
   
10. With CreateObject("vbscript.regexp")
    
11.     .Pattern = "\d+"
    
12.     .Global = True
    
13.     For i = 1 To UBound(ar)
    
14.         For Each K In .Execute(ar(i, 1))
    
15.             d(Val(K)) = i
    
16.         Next
    
17.     Next
    
18. End With
    
19. ar = Range("I7:I" & [I65536].End(3).Row).Value
    
20. ReDim b(1 To UBound(ar), 1 To 5)
    
21. For i = 1 To UBound(ar)
    
22.     K = ar(i, 1): t = d(K)
    
23.     b(i, t) = K
    
24.     If rng Is Nothing Then
    
25.         Set rng = Cells(i + 6, t + 10)
    
26.     Else
    
27.         Set rng = Union(rng, Cells(i + 6, t + 10))
    
28.     End If
    
29. Next
    
30. [k7].Resize(i - 1, 5).Clear
    
31. [k7].Resize(i - 1, 5) = b
    
32. [k7].Resize(i - 1, 5).Borders.LineStyle = xlDouble
    
33. rng.Interior.Color = vbYellow
    
34. rng.Font.Bold = 1
    
35. 
    
36. Set d = CreateObject("scripting.dictionary")
    
37. ar = [Q1].CurrentRegion.Value
    
38. ReDim b(UBound(ar))
    
39. With CreateObject("vbscript.regexp")
    
40.     .Pattern = "\d+"
    
41.     .Global = True
    
42.     For i = 1 To UBound(ar)
    
43.         For Each K In .Execute(ar(i, 1))
    
44.             d(Val(K)) = i
    
45.         Next
    
46.     Next
    
47. End With
    
48. 
    
49. ar = Range("C7:C" & [C65536].End(3).Row).Value
    
50. ReDim M(1 To UBound(ar), 1 To 5)
    
51. For i = 1 To UBound(ar)
    
52.     K = ar(i, 1): t = d(K)
    
53.     M(i, t) = K
    
54.     If rng Is Nothing Then
    
55.         Set rng = Cells(i + 6, t + 10)
    
56.     Else
    
57.         Set rng = Union(rng, Cells(i + 6, t + 10))
    
58.     End If
    
59. Next
    
60. [X7].Resize(i - 1, 5).Clear
    
61. [X7].Resize(i - 1, 5) = M
    
62. [X7].Resize(i - 1, 5).Borders.LineStyle = xlDouble
    
63. rng.Offset(0, 13).Interior.Color = vbYellow
    
64. rng.Offset(0, 13).Font.Bold = 1
    
65. 
    
66. 
    
67. 
    
68. 
    
69. End Sub
    

复制代码

liulang0808

附件内容供参考。。。

鄂龙蒙

1. Sub z()
   
2.     Dim ar, b(), M(), d As Object, rng As Range
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     ar = [Q1].CurrentRegion.Value
   
5.     ReDim b(UBound(ar))
   
6.     With CreateObject("vbscript.regexp")
   
7.         .Pattern = "\d+"
   
8.         .Global = True
   
9.         For i = 1 To UBound(ar)
   
10.             For Each K In .Execute(ar(i, 1))
    
11.                 d(Val(K)) = i
    
12.             Next
    
13.         Next
    
14.     End With
    
15.     ar = Range("I7:I" & [I65536].End(3).Row).Value
    
16.     ReDim b(1 To UBound(ar), 1 To 5)
    
17.     For i = 1 To UBound(ar)
    
18.         K = ar(i, 1)
    
19.         t = d(K)
    
20.         b(i, t) = K
    
21.         If rng Is Nothing Then
    
22.             Set rng = Cells(i + 6, t + 10)
    
23.         Else
    
24.             Set rng = Union(rng, Cells(i + 6, t + 10))
    
25.         End If
    
26.     Next
    
27.     [k7].Resize(i - 1, 5).Clear
    
28.     [k7].Resize(i - 1, 5) = b
    
29.     [k7].Resize(i - 1, 5).Borders.LineStyle = xlDouble
    
30.     rng.Interior.Color = vbYellow
    
31.     rng.Font.Bold = 1
    
32.    
    
33.     ar = Range("C7:C" & [C65536].End(3).Row).Value
    
34.     ReDim M(1 To UBound(ar), 1 To 5)
    
35.     For i = 1 To UBound(ar)
    
36.         K = ar(i, 1)
    
37.         t = d(K)
    
38.         M(i, t) = K
    
39.         If rng Is Nothing Then
    
40.             Set rng = Cells(i + 6, t + 23)
    
41.         Else
    
42.             Set rng = Union(rng, Cells(i + 6, t + 23))
    
43.         End If
    
44.     Next
    
45.     [X7].Resize(i - 1, 5).Clear
    
46.     [X7].Resize(i - 1, 5) = M
    
47.     [X7].Resize(i - 1, 5).Borders.LineStyle = xlDouble
    
48.     rng.Interior.Color = vbYellow
    
49.     rng.Font.Bold = 1
    
50. End Sub

复制代码