Помогите пожалуйста разобраться с проблемой "Ошибка "Метод PasteSpecial" из класса Range завершен неверно" Ошибка при выполнении данной функции в строке r2.PasteSpecial xlPasteFormulas, xlPasteSpecialOperationNone, True, False ошибка непостояная возникает в разных итоговых строках а может и не быть Excel2010
[vba]
Код
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
[/vba]
Помогите пожалуйста разобраться с проблемой "Ошибка "Метод PasteSpecial" из класса Range завершен неверно" Ошибка при выполнении данной функции в строке r2.PasteSpecial xlPasteFormulas, xlPasteSpecialOperationNone, True, False ошибка непостояная возникает в разных итоговых строках а может и не быть Excel2010
[vba]
Код
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