Ошибка "Метод PasteSpecial" из класса Range завершен неверно
#38611585
Ссылка:
Ссылка на сообщение:
Ссылка с названием темы:
|
|
|
Помогите пожалуйста разобраться с проблемой "Ошибка "Метод PasteSpecial" из класса Range завершен неверно"
Ошибка при выполнении данной функции в строке
r2.PasteSpecial xlPasteFormulas, xlPasteSpecialOperationNone, True, False
ошибка непостояная возникает в разных итоговых строках а может и не быть
Excel2010
1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 14. 15. 16. 17. 18. 19. 20. 21. 22. 23. 24. 25. 26. 27. 28. 29. 30. 31. 32. 33. 34. 35. 36. 37. 38. 39. 40. 41. 42. 43. 44. 45. 46. 47. 48. 49. 50. 51. 52. 53. 54. 55. 56. 57. 58. 59. 60. 61. 62. 63. 64. 65. 66. 67. 68. 69. 70. 71. 72. 73. 74. 75. 76. 77. 78. 79. 80. 81. 82. 83. 84. 85. 86. 87. 88. 89. 90. 91. 92. 93. 94. 95. 96. 97. 98. 99. 100. 101. 102. 103. 104. 105. 106. 107. 108. 109. 110. 111. 112. 113. 114. 115. 116. 117. 118. 119. 120.
Public Sub xlrGroupEx2(Args As Variant)
Dim Sheet As Worksheet
Dim Root As Range, HeaderRow As Range, GroupRow As Range, R As Range
Dim Ranges As Variant, Groups As Variant, Funcs As Variant, FuncCols As Variant
Dim Disabled As Variant, PageBreaks As Variant, MergeLabels As Variant
Dim ColumnCount As Long, GroupCount As Long, FuncCount As Long, LevelCount As Long
Dim GroupIndex As Long, FuncIndex As Long, Row As Long, Level As Long, SummaryAbove As Boolean
Dim Processed As Boolean, LastRow As Long, r1 As Range, r2 As Range, i As Long
Rem
Call xlrGetRanges(Args, Ranges)
Rem
Set Root = Range(Args(1))
Set HeaderRow = Root.Rows(0)
Set GroupRow = Root.Rows(Root.Rows.Count)
Set Sheet = Root.Parent
Groups = Args(5)
GroupCount = UBound(Groups)
Funcs = Args(6)
FuncCols = Args(7)
FuncCount = UBound(Funcs)
MergeLabels = Args(11)
Disabled = Args(14)
LevelCount = Args(15)
PageBreaks = Args(17)
ColumnCount = Root.Columns.Count
SummaryAbove = Args(8) = xlSummaryAbove
Rem
Application.DisplayAlerts = False
Rem
If Not IsArray(Ranges) Then Exit Sub
If (UBound(Ranges) \ 2) > 1 Then Exit Sub
Rem
Rem DoGroup
Level = 1
For GroupIndex = 1 To GroupCount
If Not Disabled(GroupIndex) Then
For FuncIndex = 1 To FuncCount
Set R = Sheet.Range(HeaderRow.Rows(1), Root.Rows(Root.Rows.Count - 1))
R.Subtotal Groups(GroupIndex), Funcs(FuncIndex), FuncCols(FuncIndex), False, PageBreaks(GroupIndex), Args(8)
Level = Level + 1
Next
End If
Next
Rem
Rem DoFormat
If Level > 7 Then Level = 7
Set Root = Sheet.Range(HeaderRow.Rows(2), Root.Rows(Root.Rows.Count - 1))
Set r1 = Root
Sheet.Outline.ShowLevels Level
Set Root = Root.SpecialCells(xlCellTypeVisible)
Set R = GroupRow.SpecialCells(xlCellTypeVisible)
If R.Address = GroupRow.Address Then
GroupRow.Copy
Root.Rows.PasteSpecial xlPasteFormulas, xlPasteSpecialOperationNone, True, False
Root.Rows.PasteSpecial xlPasteFormats, xlPasteSpecialOperationNone, False, False
Else
LastRow = -1
For Each R In Root.Areas
GroupRow.Copy
If LastRow < R.Row Then
LastRow = R.Row
For i = 1 To R.Rows.Count
Set r2 = r1.Rows(R.Row - r1.Row + i)
r2.PasteSpecial xlPasteFormats, xlPasteSpecialOperationNone, False, False
r2.PasteSpecial xlPasteFormulas, xlPasteSpecialOperationNone, True, False
LastRow = LastRow + 1
Next
End If
Next
End If
Sheet.Outline.ShowLevels Level + 1
Set Root = Sheet.Range(Args(1))
Rem
Rem Delete GrandTotals
If Not SummaryAbove Then
Row = Root.Rows.Count - 1 - FuncCount
Processed = False
Do While Not Processed
Processed = Root.Rows(Row).OutlineLevel = 2
If Not Processed Then Root.Rows(Row).Delete xlShiftUp
Row = Row - 1
Loop
End If
Rem
Rem Rebuild range name
Set Root = Sheet.Range(HeaderRow.Rows(2).Cells(1, 1), Root.Cells(Root.Rows.Count, Root.Columns.Count))
ThisWorkbook.Names(Args(1)).Delete
ThisWorkbook.Names.Add Name:=Args(1), RefersTo:="=" & Chr(39) & Sheet.Name & Chr(39) & "!" & _
Root.Address(True, True, xlA1, False)
Rem
Rem Do merge labels
Set Root = Range(Args(1))
Set Root = Sheet.Range(Root.Cells(1, 1), GroupRow.Rows(0))
Call xlrGroupEx2_DoGroup(Args(1), Root, SummaryAbove, Groups, MergeLabels, Args(10), FuncCount, GroupRow)
Rem
Rem Disable GrandTotals
If Args(16) Then
If Not SummaryAbove Then
Set Root = Sheet.Range(Root.Cells(Root.Rows.Count - FuncCount + 1, 1), Root.Cells(Root.Rows.Count, Root.Columns.Count))
Root.Delete xlShiftUp
Set Root = Range(Args(1))
Root.Rows.Ungroup
Else
Set Root = Sheet.Range(Root.Cells(1, 1), Root.Cells(FuncCount, Root.Columns.Count))
Root.EntireRow.Delete xlShiftUp
Set Root = Range(Args(1))
Root.Rows.Ungroup
End If
End If
Rem
GroupRow.Rows(1).Delete xlShiftUp
Rem
If Args(9) > 0 Then
Sheet.Outline.ShowLevels (Args(9))
Else
Sheet.Outline.ShowLevels Level + 1
End If
Rem
Application.DisplayAlerts = True
End Sub
|
|