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

Вход

Регистрация

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

 

= Мир MS Excel/уникальные значения в один список из всех листов книги (VBA) - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » уникальные значения в один список из всех листов книги (VBA) (Макросы/Sub)
уникальные значения в один список из всех листов книги (VBA)
ant1k2 Дата: Воскресенье, 07.02.2016, 23:53 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 1
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Здравствуйте!
Столкнулся с проблемой создания единого списка уникальных значений из данных нескольких листов одной книги при выполнении 2-х условий значениями.
Проблему решил только на 1-м листе а связать всю книгу не могу :( Решения прошу предлагать только при помощи VBA.
Пример прилагаю.
К сообщению приложен файл: Tips_All_Extrac.xlsm (27.0 Kb)
 
Ответить
СообщениеЗдравствуйте!
Столкнулся с проблемой создания единого списка уникальных значений из данных нескольких листов одной книги при выполнении 2-х условий значениями.
Проблему решил только на 1-м листе а связать всю книгу не могу :( Решения прошу предлагать только при помощи VBA.
Пример прилагаю.

Автор - ant1k2
Дата добавления - 07.02.2016 в 23:53
Hugo Дата: Понедельник, 08.02.2016, 00:30 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3250
Репутация: 707 ±
Замечаний: 0% ±

2019
С минимальной доработкой:
[vba]
Код
Sub Extract_Unique_for_Criteria_VIDPUSTKA()
    Dim rCell As Range, avArr, li As Long, vCriteria, mCritetia
    ReDim avArr(1 To Rows.Count, 1 To 1)
    'Запоминаем критерий
    vCriteria = Sheets(1).[D1].Value    'условие 1
    mCritetia = Sheets(1).[D2].Value    'условие 2
    Dim col As New Collection
    Sheets(Sheets.Count).UsedRange.Clear
        On Error Resume Next
        Dim x&
        For x = 1 To Sheets.Count - 1
            With Sheets(x)
                For Each rCell In .Range("B2", .Cells(.Rows.Count, 2).End(xlUp))
                    'В скобках вписан номер столбца, отчет с Б2 для 1 и 2 условия
                    If rCell.Offset(, -1).Value = vCriteria And rCell.Offset(, 1).Value = mCritetia Then
                        'Cells(Rows.Count, 2).End(xlUp) - определяет последнюю заполненную ячейку в столбце B
                        col.Add rCell.Value, CStr(rCell.Value)
                        If Err = 0 Then
                            li = li + 1: avArr(li, 1) = rCell.Value
                        Else: Err.Clear
                        End If
                    End If
                Next
            End With
        Next
    'куда вставить столбец с какой строки
    If li Then Sheets(Sheets.Count).[E2].Resize(li).Value = avArr
End Sub
[/vba]
Но лучше доработать чуть больше:
[vba]
Код
Sub Extract_Unique_for_Criteria_VIDPUSTKA()
    Dim rCell As Range, avArr, li As Long, vCriteria, mCritetia
    ReDim avArr(1 To Rows.Count, 1 To 1)
    'Запоминаем критерий
    vCriteria = Sheets(1).[D1].Value    'условие 1
    mCritetia = Sheets(1).[D2].Value    'условие 2
    Dim col As New Collection
    Sheets(Sheets.Count).UsedRange.Clear
    On Error Resume Next
    Dim x&
    For x = 1 To Sheets.Count - 1
        With Sheets(x)
            For Each rCell In .Range("B2", .Cells(.Rows.Count, 2).End(xlUp))
                'В скобках вписан номер столбца, отчет с Б2 для 1 и 2 условия
                If rCell.Offset(, -1).Value = vCriteria And rCell.Offset(, 1).Value = mCritetia Then
                    'Cells(Rows.Count, 2).End(xlUp) - определяет последнюю заполненную ячейку в столбце B
                    col.Add rCell.Value, CStr(rCell.Value)
                End If
            Next
        End With
    Next
    On Error GoTo 0
    
    If col.Count Then
        'куда вставить столбец с какой строки
        ReDim avArr(1 To col.Count, 1 To 1)
        For li = 1 To col.Count
            avArr(li, 1) = col(li)
        Next
        Sheets(Sheets.Count).[E2].Resize(col.Count).Value = avArr
    End If
End Sub
[/vba]


excel@nxt.ru
webmoney: E265281470651 Z422237915069


Сообщение отредактировал Hugo - Понедельник, 08.02.2016, 00:38
 
Ответить
СообщениеС минимальной доработкой:
[vba]
Код
Sub Extract_Unique_for_Criteria_VIDPUSTKA()
    Dim rCell As Range, avArr, li As Long, vCriteria, mCritetia
    ReDim avArr(1 To Rows.Count, 1 To 1)
    'Запоминаем критерий
    vCriteria = Sheets(1).[D1].Value    'условие 1
    mCritetia = Sheets(1).[D2].Value    'условие 2
    Dim col As New Collection
    Sheets(Sheets.Count).UsedRange.Clear
        On Error Resume Next
        Dim x&
        For x = 1 To Sheets.Count - 1
            With Sheets(x)
                For Each rCell In .Range("B2", .Cells(.Rows.Count, 2).End(xlUp))
                    'В скобках вписан номер столбца, отчет с Б2 для 1 и 2 условия
                    If rCell.Offset(, -1).Value = vCriteria And rCell.Offset(, 1).Value = mCritetia Then
                        'Cells(Rows.Count, 2).End(xlUp) - определяет последнюю заполненную ячейку в столбце B
                        col.Add rCell.Value, CStr(rCell.Value)
                        If Err = 0 Then
                            li = li + 1: avArr(li, 1) = rCell.Value
                        Else: Err.Clear
                        End If
                    End If
                Next
            End With
        Next
    'куда вставить столбец с какой строки
    If li Then Sheets(Sheets.Count).[E2].Resize(li).Value = avArr
End Sub
[/vba]
Но лучше доработать чуть больше:
[vba]
Код
Sub Extract_Unique_for_Criteria_VIDPUSTKA()
    Dim rCell As Range, avArr, li As Long, vCriteria, mCritetia
    ReDim avArr(1 To Rows.Count, 1 To 1)
    'Запоминаем критерий
    vCriteria = Sheets(1).[D1].Value    'условие 1
    mCritetia = Sheets(1).[D2].Value    'условие 2
    Dim col As New Collection
    Sheets(Sheets.Count).UsedRange.Clear
    On Error Resume Next
    Dim x&
    For x = 1 To Sheets.Count - 1
        With Sheets(x)
            For Each rCell In .Range("B2", .Cells(.Rows.Count, 2).End(xlUp))
                'В скобках вписан номер столбца, отчет с Б2 для 1 и 2 условия
                If rCell.Offset(, -1).Value = vCriteria And rCell.Offset(, 1).Value = mCritetia Then
                    'Cells(Rows.Count, 2).End(xlUp) - определяет последнюю заполненную ячейку в столбце B
                    col.Add rCell.Value, CStr(rCell.Value)
                End If
            Next
        End With
    Next
    On Error GoTo 0
    
    If col.Count Then
        'куда вставить столбец с какой строки
        ReDim avArr(1 To col.Count, 1 To 1)
        For li = 1 To col.Count
            avArr(li, 1) = col(li)
        Next
        Sheets(Sheets.Count).[E2].Resize(col.Count).Value = avArr
    End If
End Sub
[/vba]

Автор - Hugo
Дата добавления - 08.02.2016 в 00:30
Мир MS Excel » Вопросы и решения » Вопросы по VBA » уникальные значения в один список из всех листов книги (VBA) (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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