Адаптация макроса VBA (копирование со скрытыми строками)

[Artem_]

Добрый день.

Прошу помощи в адаптации макроса VBA в Basic (LO).
Макрос делает:
1. Копирует значения из ячеек с учетом скрытых строк (аналогия с Copy only visible)
2. Вставляет скопированные значения в ячейки с учетом скрытых строк.

Макрос на VBA рабочий 100%.
Брал его отсюда из комментариев внизу:
https://www.planetaexcel.ru/techniques/2/173/
Пост от Ирек Афтахов 09.07.2014 17:04:54


Код VBA:

Код Выделить Развернуть

Sub PasteToVisible()
Dim copyrng As Range, pasterng As Range
Dim cell As Range, i As Long

'запрашиваем у пользователя по очереди диапазоны копирования и вставки
Set copyrng = Application.InputBox("Диапазон копирования", "Запрос", Type:=8)
Set pasterng = Application.InputBox("Диапазон вставки", "Запрос", Type:=8)

'проверяем, чтобы они были одинакового размера
If pasterng.Cells.Cells.Count <> copyrng.Cells.Count Then
MsgBox "Диапазоны копирования и вставки разного размера!",vbCritical
Exit Sub
End If

'переносим данные из одного диапазона в другой только в видимые ячейки
For Each cell In pasterng
If cell.EntireRow.Hidden = False Then
cell.Value = Cells(cell.Row, copyrng.Column).Value
End If
  Next cell
End Sub


----------------------
----------------------
Код полученный с помощью конвертера ( на сайте https://www.business-spreadsheets.com/vba2oo.asp):

Код Выделить Развернуть

Sub PasteToVisible()
Dim copyrng As Dim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1), pasterng As Dim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1)
Dim cell As Dim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1), i As Long

'запрашиваем у пользователя по очереди диапазоны копирования и вставки
Set copyrng = Application.InputBox("Диапазон копирования", "Запрос", Type:=8)
Set pasterng = Application.InputBox("Диапазон вставки", "Запрос", Type:=8)

'проверяем, чтобы они были одинакового размера
If pasterng.Cells.Cells.Count <> copyrng.Cells.Count Then
MsgBox "Диапазоны копирования и вставки разного размера!",vbCritical
Exit Sub
End If

'переносим данные из одного диапазона в другой только в видимые ячейки
For Each cell In pasterng
If cell.EntireRow.Hidden = False Then
cell.Value = Cells(cell.Row, copyrng.Column).Value
End If
  Next cell
End Sub


------------------------
Код полученный конвертером - не работает.

Как альтернативу, пробовал:
1. Copy only visible cells
2. Ctrl_Shift_V - Skip empty clls
Не работает, выдает "Невозможно вставить в мультивыделение". При этом курсор установлен в одной ячейке. При выделении диапазона куда нужно вставить, вообще ничего не происходит, даже нет ошибки.

Option VBASupport 1 - в начале кода тоже не помогает.

Буду признателен за помощь. На месте работы организация перешла с MS на LO. Макрос в работе очень желателен.

Артем,
vocativ7@gmail.com

[sokol92]

Для копирования строк диапазона в видимые строки другого диапазона можно использовать макрос:

Код Выделить Развернуть

Sub CopyRange
  Dim oDoc, oSrc, oDest
  oDoc=ThisComponent
 
  'запрашиваем у пользователя по очереди диапазоны копирования и вставки
  oSrc=RangeSelect(oDoc, "Диапазон копирования")
  If oSrc Is Nothing Then Exit Sub
  oDest=RangeSelect(oDoc, "Диапазон вставки")
  If oDest Is Nothing Then Exit Sub

  'проверяем, чтобы они были одинакового размера
  If oSrc.Rows.Count<>oDest.Rows.Count Or oSrc.Columns.Count<>oDest.Columns.Count Then
    MsgBox "Диапазоны копирования и вставки разного размера!", 16
    Exit Sub
  End If 
   
  RangeCopyToVisible oSrc, oDest
End Sub

' Копирует значения ячееек диапазона в соответствующие ячейки видимых строк другого диапазона.
' - oSrc  Исходный прямоугольный диапазон.
' - oDest Целевой диапазон.
Sub RangeCopyToVisible(ByVal oSrc, Byval oDest)
  Dim dataArr, i As Long
  dataArr=oSrc.DataArray 
  For i=0 To Ubound(dataArr)
    If oDest.Rows(i).IsVisible Then
      oDest.getCellRangeByPosition(0, i, Ubound(dataArr(i)), i).DataArray=Array(dataArr(i))
    End If 
  Next i 
End Sub


Поместите следующие макросы в отдельный модуль библиотеки.

Код Выделить Развернуть

Option Explicit

' lang:en
' Macro for interactively selecting a range of cells.
' lang:ru
' Макрос для интерактивного выбора диапазона ячеек.

Dim RangeSelectRange
Dim RangeSelectDone

' ------------------------------------------------------------------
' lang:en
' Call a dialog for selecting rectangular range of cells in document.
' - oDoc           Calc document.
' - Title          Title of dialog window.
' - SingleCellMode True - select one cell, False (default) - range.
' - InitialValue   Initial value for the dialog (in the format of a cell/range address).
'
' Example: RangeSelect(ThisComponent, "Specify a cell to copy", True, "$Sheet2.D5")
'
' lang:ru
' Вызов диалога для выбора прямоугольного диапазона ячеек в документе.
' - oDoc            Документ Calc.
' - Title           Заголовок окна.
' - SingleCellMode  True - выбор одной ячейки, False (умолчание) - диапазона.
' - InitialValue    Начальное значение для диалога (в формате адреса ячейки / диапазона ячеек).
'
' Пример: RangeSelect(ThisComponent, "Укажите ячейку для копирования", True, "$Лист2.D5")
'
Function RangeSelect(Byval oDoc, Optional ByVal Title As String, _
   Optional ByVal SingleCellMode As Boolean, Optional Byval InitialValue As String) As Object
   Dim oRSList, aProps(3) As New com.sun.star.beans.PropertyValue
   
   If IsMissing(Title) Then Title=""
   If IsMissing(SingleCellMode) Then SingleCellMode=False
   If IsMissing(InitialValue) Then InitialValue=""
   aProps(0).Name="InitialValue"        : aProps(0).Value=InitialValue
   aProps(1).Name="Title"               : aProps(1).Value=Title
   aProps(2).Name="CloseOnMouseRelease" : aProps(2).Value=False           'true — закрывается само, false — вручную
   aProps(3).Name="SingleCellMode"      : aProps(3).Value=SingleCellMode
   oRSList=CreateUnoListener("RangeSelect_","com.sun.star.sheet.XRangeSelectionListener")
   RangeSelectRange=Nothing
   With oDoc.CurrentController
     .addRangeSelectionListener(oRSList)
     RangeSelectDone=False
     .startRangeSelection(aProps())
     While Not RangeSelectDone
       Wait 1000
     Wend 
     .removeRangeSelectionListener(oRSList)         
   End With   
   RangeSelect=RangeSelectRange
End Function

' ------------------------------------------------------------------
' lang:en
' Event handler.
' lang:ru
' Обработчик события.
Sub RangeSelect_done(e)
   If e.RangeDescriptor="" Then
     RangeSelectRange=Nothing
   Else
     RangeSelectRange=e.Source.Model.Sheets.getCellRangesByName(e.RangeDescriptor)(0)
   End If 
   RangeSelectDone=True
End Sub

' lang:en
' Event handler.
' lang:ru
' Обработчик события.
Sub RangeSelect_aborted(e)
  RangeSelectRange=Nothing
  RangeSelectDone=True
End Sub

' lang:en
' Event handler.
' lang:ru
' Обработчик события.
Sub RangeSel_disposing(e)
  RangeSelectRange=Nothing    ' на всякий случай.
  RangeSelectDone=True
End Sub


Для выбора диапазона ячеек на сайте есть отличный макрос от @Rami.

[sokol92]

Собрал в предыдущем ответе всё вместе.

[Artem_]

Доброе утро.
Спасибо за помощь.
Проверил, все работает.
Уверен, пригодится не только мне.