Являюсь счастливым обладателем данной настройки) Есть предложение, не знаю, может уже есть такая фича, но я не нашел. Суть в том, чтобы копировать данные (ячейки, строки), когда они отфильтрованы, копировать только то что, отфильтровано, не захватывая то, что скрыто. На просторах интернет нашел макрос и использую его параллельно в виде настройки. Комбинации клавиш Ctrl+Q и Ctrl+W позволяют копировать-вставить.
Если бы, было что-то подобное в PLEX, было бы прекрасно. Хотя, повторюсь, может это уже и есть, просто я не нашел.
'--------------------------------------------------------------------------------------- ' Module : mMyCopyPast ' DateTime : 30.04.2010 10:32 ' Author : The_Prist(Дмитрий) ' Purpose : http://excel-vba.ru/index.php?file=Tips_Macro_PasteInVisible '--------------------------------------------------------------------------------------- Option Explicit Dim rCopyRange As Range 'Этим макросом копируем данные Sub My_Copy() If Selection.Count > 1 Then Set rCopyRange = Selection.SpecialCells(xlVisible) Else: Set rCopyRange = ActiveCell End If End Sub 'Этим макросом вставляем данные, начиная с выделенной ячейки Sub My_Paste() If rCopyRange Is Nothing Then Exit Sub
Dim rCell As Range, li As Long, iCalculation As Integer Dim lr As Long, lc As Long, lTmpCol As Long Dim rResCell As Range, asAddrRng, lSp As Long
Application.ScreenUpdating = False iCalculation = Application.Calculation: Application.Calculation = -4135 'получаем отсортированный нужным образом список адресов ячеек asAddrRng = NoDups(rCopyRange) 'получаем первую ячейку для вставки Set rResCell = ActiveCell 'цикл по ячейкам для копирования For lSp = LBound(asAddrRng) To UBound(asAddrRng) For Each rCell In rCopyRange.Parent.Range(asAddrRng(lSp)) If lTmpCol = 0 Then lTmpCol = rCell.Column If lTmpCol < rCell.Column Then Do lc = lc + 1 Loop While rResCell.Offset(lr, lc).EntireColumn.Hidden = True lr = 0: lTmpCol = rCell.Column End If Do If rResCell.Offset(lr, lc).EntireColumn.Hidden = False And _ rResCell.Offset(lr, lc).EntireRow.Hidden = False Then rResCell.Offset(lr, lc) = rCell.Value ' rResCell.Offset(lr, lc) = rCell.Value End If lr = lr + 1 Loop While rResCell.Offset(lr, lc).EntireRow.Hidden = True Next rCell Next lSp Application.ScreenUpdating = True: Application.Calculation = iCalculation End Sub 'получение отсортированных адресов диапазона Function NoDups(rRng As Range) Dim avArr(), rCell As Range, sAddr As String, li As Long, lr As Long Dim lRow As Long, lCol As Long, objColl As New Collection
On Error Resume Next 'сортируем по строкам With New Collection For Each rCell In rRng.Cells lRow = rCell.Row sAddr = Trim(rCell.Address(0, 0)) If Len(sAddr) > 0 Then If IsEmpty(.Item(sAddr)) Then For li = 1 To .Count If lRow < Range(.Item(li)).Row Then Exit For Next If li > .Count Then .Add sAddr, sAddr Else .Add sAddr, sAddr, Before:=li End If End If Next 'сортируем по столбцам For lr = 1 To .Count lCol = Range(.Item(lr)).Column sAddr = Range(.Item(lr)).Address(0, 0) If Len(sAddr) > 0 Then If IsEmpty(objColl.Item(sAddr)) Then For li = 1 To objColl.Count If lCol < Range(objColl.Item(li)).Column Then Exit For Next If li > objColl.Count Then objColl.Add sAddr, sAddr Else objColl.Add sAddr, sAddr, Before:=li End If End If End If Next ReDim avArr(1 To objColl.Count) For li = 1 To objColl.Count avArr(li) = objColl.Item(li) Next End With NoDups = avArr() End Function
Да, точно)) но справедливости ради, он хоть очень мощный, но для задачи именно когда, надо быстро отфильтровать, комбинацией скопировать видимое-отфильтрованное, а потом в другом месте/листе/книге вставить - не подойдет. Горячие клавиши прикрутить средствами PLEX не получается. Надо указать диапазон, а как я могу знать какой? Может быть одна ячейка, а может и 50 строк. Может, конечно, я не так понял суть настройки.