Здравствуйте! Столкнулся с проблемой создания единого списка уникальных значений из данных нескольких листов одной книги при выполнении 2-х условий значениями. Проблему решил только на 1-м листе а связать всю книгу не могу Решения прошу предлагать только при помощи VBA. Пример прилагаю.
Здравствуйте! Столкнулся с проблемой создания единого списка уникальных значений из данных нескольких листов одной книги при выполнении 2-х условий значениями. Проблему решил только на 1-м листе а связать всю книгу не могу Решения прошу предлагать только при помощи VBA. Пример прилагаю.ant1k2
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]
С минимальной доработкой: [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