Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Метод PasteSpecial из класса Range завершен неверно - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Метод PasteSpecial из класса Range завершен неверно
niru1980 Дата: Понедельник, 14.04.2014, 13:01 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 38
Репутация: 1 ±
Замечаний: 0% ±

Excel 2010
Помогите пожалуйста разобраться с проблемой "Ошибка "Метод 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
[/vba]

Автор - niru1980
Дата добавления - 14.04.2014 в 13:01
Serge_007 Дата: Среда, 12.01.2022, 11:35 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 16475
Репутация: 2749 ±
Замечаний: ±

Excel 2016
тест


ЮMoney:41001419691823 | WMR:126292472390
 
Ответить
Сообщениетест

Автор - Serge_007
Дата добавления - 12.01.2022 в 11:35
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!