Прикрепил обновленные файлы.
Файл "К1", ячейка E21, результат "1-3".
1) Условие1 из ячейки А21 = 1005 (в файле "К2" осуществляется поиск этого значения по столбцу О)
2) Условие2 из ячейки С21 = 1 (в файле "К2" осуществляется поиск этого значения по столбцу В)
3 Условие3 из ячейки D21 =
1 (значит в файле "К2" осуществляется поиск даты E20 (01.06.2021)
из столбца C)
все строки файла "К2" проверены, под все условия попало 3 строки, у которых по столбцу А значения равны 1, 2 и 3. Т.к. значения последовательны, выводится результат "1-3".
Этому соответствует код:
со строкой If arr2(1, i) =
arr(n, 3) And arr(n, 15) = m And arr3(n, 2) = mm Then
| Код |
|---|
Sub Ìàêðîñ1()
Dim arr, arr2, arr3, arr4, i As Long, n As Long, lr As Long, lcol As Long, tt As String, col As New Collection, fl As Boolean, m As Range, mm As Range, mmm As Range
Set m = [A21]
Set mm = m.Offset(0, 2)
Set mmm = mm.Offset(0, 2)
Set wb = ThisWorkbook: Set wb2 = Workbooks("Ê2.xlsx")
lr = wb2.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
lcol = Cells(20, Columns.Count).End(xlToLeft).Column
arr = wb2.Sheets(2).Range("A2:O" & lr)
arr2 = wb.Sheets(1).Range(Cells(20, 5), Cells(20, lcol))
arr3 = wb2.Sheets(2).Range("A2:O" & lr)
ReDim arr4(1 To 1, 1 To UBound(arr2, 2) - LBound(arr2) + 1): K = 1
For i = LBound(arr2) To UBound(arr2, 2) - LBound(arr2) + 1
tt = ""
Set col = Nothing
For n = LBound(arr) To UBound(arr)
If arr2(1, i) = arr(n, 3) And arr(n, 15) = m And arr3(n, 2) = mm Then
On Error Resume Next
col.Add arr(n, 1), CStr(arr(n, 1))
End If
Next n
For n = 1 To col.Count
tt = tt & ", " & col(n)
Do While col(n) = col(n + 1) - 1 And n < col.Count
fl = True: n = n + 1
If n >= col.Count Then Exit Do
Loop
If fl Then tt = tt & "-" & col(n): fl = False
Next n
arr4(1, K) = Mid(tt, 3): K = K + 1
Next i
mmm.Resize(1, UBound(arr4, 2) - LBound(arr4) + 1).NumberFormat = "@"
mmm.Resize(1, UBound(arr4, 2) - LBound(arr4) + 1) = arr4
End Sub
|
Файл "К1", ячейка E25, результат "пусто" (нет данных)
Файл "К1", ячейка F25, результат 1-5, 8"
1) Условие1 из ячейки А21 = 1005 (в файле "К2" осуществляется поиск этого значения по столбцу О)
2) Условие2 из ячейки С25 = 1 (в файле "К2" осуществляется поиск этого значения по столбцу В)
3 Условие3 из ячейки D21 =
5 (значит в файле "К2" осуществляется поиск даты F20 (02.06.2021)
из столбца E)
все строки файла "К2" проверены, под все условия попало 6 строк, у которых по столбцу А значения равны 1, 2, 3, 4, 5 и 8. Т.к. значения 1, 2, 3, 4, 5 последовательны, а 8 нет, выводится результат "1-5, 8"
Этому соответствует код:
Скрытый текст |
|---|
со строкой If arr2(1, i) = arr(n, 5) And arr(n, 15) = m And arr3(n, 2) = mm Then
Скрытый текст |
|---|
| Код |
|---|
Sub Ìàêðîñ2()
Dim arr, arr2, arr3, arr4, i As Long, n As Long, lr As Long, lcol As Long, tt As String, col As New Collection, fl As Boolean, m As Range, mm As Range, mmm As Range
Set m = [A21]
Set mm = m.Offset(0, 2)
Set mmm = mm.Offset(0, 2)
Set wb = ThisWorkbook: Set wb2 = Workbooks("Ê2.xlsx")
lr = wb2.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
lcol = Cells(20, Columns.Count).End(xlToLeft).Column
arr = wb2.Sheets(2).Range("A2:O" & lr)
arr2 = wb.Sheets(1).Range(Cells(20, 5), Cells(20, lcol))
arr3 = wb2.Sheets(2).Range("A2:O" & lr)
ReDim arr4(1 To 1, 1 To UBound(arr2, 2) - LBound(arr2) + 1): K = 1
For i = LBound(arr2) To UBound(arr2, 2) - LBound(arr2) + 1
tt = ""
Set col = Nothing
For n = LBound(arr) To UBound(arr)
If arr2(1, i) = arr(n, 5) And arr(n, 15) = m And arr3(n, 2) = mm Then
On Error Resume Next
col.Add arr(n, 1), CStr(arr(n, 1))
End If
Next n
For n = 1 To col.Count
tt = tt & ", " & col(n)
Do While col(n) = col(n + 1) - 1 And n < col.Count
fl = True: n = n + 1
If n >= col.Count Then Exit Do
Loop
If fl Then tt = tt & "-" & col(n): fl = False
Next n
arr4(1, K) = Mid(tt, 3): K = K + 1
Next i
mmm.Resize(1, UBound(arr4, 2) - LBound(arr4) + 1).NumberFormat = "@"
mmm.Resize(1, UBound(arr4, 2) - LBound(arr4) + 1) = arr4
End Sub
|
|
|
