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

Вход

Регистрация

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

 

= Мир MS Excel/Копирование только видимого диапазона ячеек из Inputbox - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование только видимого диапазона ячеек из Inputbox (Макросы/Sub)
Копирование только видимого диапазона ячеек из Inputbox
t330 Дата: Среда, 29.01.2020, 13:18 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Добрый день всем!

Помогите пожалуйста разобрать код ниже!

Есть код ниже, который копирует позволяет копировать уникальные строки из выбранного юзером в ИНПУТБОКСе диапазона.

Беда в том, что если в выбранном юзером диапазоне есть свернутые и скрытые ячейки (см вложенный файл), то эти ячейки тоже копируются.

Вопросы:
1. Как сделать так, чтобы копировались только видимые ячеки из выбранного юзером диапазона?
Я пытался заменить строку 10 вот таким выражением, чтобы получать только видимые ячейки:
[vba]
Код
Set rVals = Intersect(rVals, rVals.Parent.UsedRange).SpecialCells(xlCellTypeVisible)
[/vba]
не работает

2. В строке 20 в переменную avVals пишутся все значения из диапазона rVals , а потом в строке 30 появляется какая-то БЕЗЫМЯННАЯ коллекция ...
Как такое получилось ? Как можно добавить какую-то Коллекцию без имени прямо в середине кода без объявления этой Коллекции в начале кода выражением типа [vba]
Код
Dim  Coll  as new Collection
[/vba]
?

[vba]
Код


Option Explicit

Sub Extract_Unique()
    Dim x, avArr, li As Long
    Dim avVals
    Dim rVals As Range, rResultCell As Range

    On Error Resume Next
    'запрашиваем адрес ячеек для выбора уникальных значений
    Set rVals = Application.InputBox("Укажите диапазон ячеек для выборки уникальных значений", "Запрос данных", "A2:A10", Type:=8)
        
    If rVals Is Nothing Then 'если нажата кнопка Отмена
        Exit Sub
    End If
    'если указана только одна ячейка - нет смысла выбирать
    If rVals.Count = 1 Then
        MsgBox "Для отбора уникальных значений требуется указать более одной ячейки", vbInformation, "www.excel-vba.ru"
        Exit Sub
    End If
    'отсекаем пустые строки и столбцы вне рабочего диапазона и все скрытые и свернутые строки
   10  Set rVals = Intersect(rVals, rVals.Parent.UsedRange)
    'если указаны только пустые ячейки вне рабочего диапазона
    
    If rVals Is Nothing Then
        MsgBox "Недостаточно данных для выбора значений", vbInformation, "www.excel-vba.ru"
        Exit Sub
    End If
    
    20 avVals = rVals.Value
    
  
    'запрашиваем ячейку для вывода результата
    Set rResultCell = Application.InputBox("Укажите ячейку для вставки отобранных уникальных значений", "Запрос данных", "E2", Type:=8)
    If rResultCell Is Nothing Then 'если нажата кнопка Отмена
        Exit Sub
    End If
    'определяем максимально возможную размерность массива для результата
    ReDim avArr(1 To rVals.Rows.Count, 1 To 1)
    'при помощи объекта Коллекции(Collection)
    'отбираем только уникальные записи,
    'т.к. Коллекции не могут содержать повторяющиеся значения
  30  With New Collection
        On Error Resume Next
        For Each x In avVals
            If Len(CStr(x)) Then 'пропускаем пустые ячейки
                .Add x, CStr(x) 'если добавляемый элемент уже есть в Коллекции - возникнет ошибка
                'если же ошибки нет - такое значение еще не внесено,
                'добавляем в результирующий массив
                If Err = 0 Then
                    li = li + 1
                    avArr(li, 1) = x
                Else
                    'обязательно очищаем объект Ошибки
                    Err.Clear
                End If
            End If
        Next
    End With
    'записываем результат на лист, начиная с указанной ячейки
    If li Then rResultCell.Cells(1, 1).Resize(li).Value = avArr
End Sub

[/vba]

Кто знает , помогите пожалуйста.
Спасибо

К сообщению приложен файл: 8094404.xlsm(19.6 Kb)


Сообщение отредактировал t330 - Среда, 29.01.2020, 15:46
 
Ответить
СообщениеДобрый день всем!

Помогите пожалуйста разобрать код ниже!

Есть код ниже, который копирует позволяет копировать уникальные строки из выбранного юзером в ИНПУТБОКСе диапазона.

Беда в том, что если в выбранном юзером диапазоне есть свернутые и скрытые ячейки (см вложенный файл), то эти ячейки тоже копируются.

Вопросы:
1. Как сделать так, чтобы копировались только видимые ячеки из выбранного юзером диапазона?
Я пытался заменить строку 10 вот таким выражением, чтобы получать только видимые ячейки:
[vba]
Код
Set rVals = Intersect(rVals, rVals.Parent.UsedRange).SpecialCells(xlCellTypeVisible)
[/vba]
не работает

2. В строке 20 в переменную avVals пишутся все значения из диапазона rVals , а потом в строке 30 появляется какая-то БЕЗЫМЯННАЯ коллекция ...
Как такое получилось ? Как можно добавить какую-то Коллекцию без имени прямо в середине кода без объявления этой Коллекции в начале кода выражением типа [vba]
Код
Dim  Coll  as new Collection
[/vba]
?

[vba]
Код


Option Explicit

Sub Extract_Unique()
    Dim x, avArr, li As Long
    Dim avVals
    Dim rVals As Range, rResultCell As Range

    On Error Resume Next
    'запрашиваем адрес ячеек для выбора уникальных значений
    Set rVals = Application.InputBox("Укажите диапазон ячеек для выборки уникальных значений", "Запрос данных", "A2:A10", Type:=8)
        
    If rVals Is Nothing Then 'если нажата кнопка Отмена
        Exit Sub
    End If
    'если указана только одна ячейка - нет смысла выбирать
    If rVals.Count = 1 Then
        MsgBox "Для отбора уникальных значений требуется указать более одной ячейки", vbInformation, "www.excel-vba.ru"
        Exit Sub
    End If
    'отсекаем пустые строки и столбцы вне рабочего диапазона и все скрытые и свернутые строки
   10  Set rVals = Intersect(rVals, rVals.Parent.UsedRange)
    'если указаны только пустые ячейки вне рабочего диапазона
    
    If rVals Is Nothing Then
        MsgBox "Недостаточно данных для выбора значений", vbInformation, "www.excel-vba.ru"
        Exit Sub
    End If
    
    20 avVals = rVals.Value
    
  
    'запрашиваем ячейку для вывода результата
    Set rResultCell = Application.InputBox("Укажите ячейку для вставки отобранных уникальных значений", "Запрос данных", "E2", Type:=8)
    If rResultCell Is Nothing Then 'если нажата кнопка Отмена
        Exit Sub
    End If
    'определяем максимально возможную размерность массива для результата
    ReDim avArr(1 To rVals.Rows.Count, 1 To 1)
    'при помощи объекта Коллекции(Collection)
    'отбираем только уникальные записи,
    'т.к. Коллекции не могут содержать повторяющиеся значения
  30  With New Collection
        On Error Resume Next
        For Each x In avVals
            If Len(CStr(x)) Then 'пропускаем пустые ячейки
                .Add x, CStr(x) 'если добавляемый элемент уже есть в Коллекции - возникнет ошибка
                'если же ошибки нет - такое значение еще не внесено,
                'добавляем в результирующий массив
                If Err = 0 Then
                    li = li + 1
                    avArr(li, 1) = x
                Else
                    'обязательно очищаем объект Ошибки
                    Err.Clear
                End If
            End If
        Next
    End With
    'записываем результат на лист, начиная с указанной ячейки
    If li Then rResultCell.Cells(1, 1).Resize(li).Value = avArr
End Sub

[/vba]

Кто знает , помогите пожалуйста.
Спасибо


Автор - t330
Дата добавления - 29.01.2020 в 13:18
t330 Дата: Среда, 29.01.2020, 13:47 | Сообщение № 2
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
.


Сообщение отредактировал t330 - Среда, 29.01.2020, 19:30
 
Ответить
Сообщение.

Автор - t330
Дата добавления - 29.01.2020 в 13:47
китин Дата: Среда, 29.01.2020, 13:47 | Сообщение № 3
Группа: Модераторы
Ранг: Экселист
Сообщений: 6279
Репутация: 963 ±
Замечаний: 0% ±

Excel 2007;Excel 2010
никак


Не судите строго:я пытаюсь научиться
ЯД 41001877306852/WM R249698041931; Z239672726538
 
Ответить
Сообщениеникак

Автор - китин
Дата добавления - 29.01.2020 в 13:47
t330 Дата: Среда, 29.01.2020, 15:46 | Сообщение № 4
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Переформулировал вопрос в шапке.

Вопрос открыт:)
 
Ответить
СообщениеПереформулировал вопрос в шапке.

Вопрос открыт:)

Автор - t330
Дата добавления - 29.01.2020 в 15:46
t330 Дата: Среда, 29.01.2020, 21:32 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Поясните пожалуйста еще такой момент:

В строке 20 есть переменная avVals которую приравнивают к значениям из диапазона rVals.Value , заданного в строке 10 ....
То есть в эту переменную как в массив записываются все значения из диапазона rVals заданного в строке 10... И если пройтись дебагером через F8 до строки 20, то действительно мы увидим , что в avVals превратилась в массив со значениями из rVals

Однако, если в строке 10 вместо [vba]
Код
  Set rVals = Intersect(rVals, rVals.Parent.UsedRange)
[/vba] поставить [vba]
Код
  Set rVals = rVals.SpecialCells(xlCellTypeVisible)
[/vba], чтобы в rVals попадали только видивые ячейки, то в переменную avVals в строке 20 вообще ничего не пишется и никакой массив не создается....

Никак не пойму что за фигня...
 
Ответить
СообщениеПоясните пожалуйста еще такой момент:

В строке 20 есть переменная avVals которую приравнивают к значениям из диапазона rVals.Value , заданного в строке 10 ....
То есть в эту переменную как в массив записываются все значения из диапазона rVals заданного в строке 10... И если пройтись дебагером через F8 до строки 20, то действительно мы увидим , что в avVals превратилась в массив со значениями из rVals

Однако, если в строке 10 вместо [vba]
Код
  Set rVals = Intersect(rVals, rVals.Parent.UsedRange)
[/vba] поставить [vba]
Код
  Set rVals = rVals.SpecialCells(xlCellTypeVisible)
[/vba], чтобы в rVals попадали только видивые ячейки, то в переменную avVals в строке 20 вообще ничего не пишется и никакой массив не создается....

Никак не пойму что за фигня...

Автор - t330
Дата добавления - 29.01.2020 в 21:32
boa Дата: Четверг, 30.01.2020, 18:02 | Сообщение № 6
Группа: Проверенные
Ранг: Обитатель
Сообщений: 495
Репутация: 148 ±
Замечаний: 0% ±

2013, 365
можно сделать пользовательскую функцию
и вызвать ее
[vba]
Код
    avVals = RangeToArr(rVals)
[/vba]

[vba]
Код
Function RangeToArr(oRNG As Range)
    Dim avVals(), oRowVis As Range, i&, j&, iColCount&
    iColCount = oRNG.Columns.Count
    For Each oRowVis In oRNG.SpecialCells(xlCellTypeVisible).Rows
      i = i + 1
      ReDim Preserve avVals(1 To iColCount, 1 To i)
      For j = 1 To iColCount
        avVals(j, i) = oRowVis.Cells(j)
      Next
    Next
    RangeToArr = Application.WorksheetFunction.Transpose(avVals)
End Function
[/vba]


 
Ответить
Сообщениеможно сделать пользовательскую функцию
и вызвать ее
[vba]
Код
    avVals = RangeToArr(rVals)
[/vba]

[vba]
Код
Function RangeToArr(oRNG As Range)
    Dim avVals(), oRowVis As Range, i&, j&, iColCount&
    iColCount = oRNG.Columns.Count
    For Each oRowVis In oRNG.SpecialCells(xlCellTypeVisible).Rows
      i = i + 1
      ReDim Preserve avVals(1 To iColCount, 1 To i)
      For j = 1 To iColCount
        avVals(j, i) = oRowVis.Cells(j)
      Next
    Next
    RangeToArr = Application.WorksheetFunction.Transpose(avVals)
End Function
[/vba]

Автор - boa
Дата добавления - 30.01.2020 в 18:02
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование только видимого диапазона ячеек из Inputbox (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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