Страницы: 1 2 След.
RSS
Поиск значений в другой книге
 
Помогите с решением такой задачи.
В столбце L лист Реестр книги БазаАктов надо вставить значения из столбцов S, T, V листа Бетон книги Ведомость объемов

1е условие: значение  столбца H листа Реестр книги БазаАктов должно совпадать с значением в столбце A листа Бетон книги Ведомость объемов

2е условие:

-если значение в столбце F листа Реестр книги БазаАктов = "Бетонирование бетонной  подготовки", то берутся значения из толбца V листа Бетон книги Ведомость объемов                    

-если значение в столбце F листа Реестр книги БазаАктов = "Бетонирование плиты днища", то берутся значения из толбца S листа Бетон книги Ведомость объемов                  

-если значение в столбце F листа Реестр книги БазаАктов = "Бетонирование стен", то берутся значения из толбца T листа Бетон книги Ведомость объемов

3е условие: если в столбце H листа Реестр книги БазаАктов несколько значений, то соответствующие значения из столбцов S, T, V листа Бетон книги Ведомость объемов должны суммироваться

За ранее спасибо))
Изменено: narod svs - 29.04.2022 14:48:55
 
Цитата
narod svs написал:
столбца H листа Реестр книги БазаАктов должно совпадать с значением
Совпадение будет точное или нет
 
Цитата
написал:
Совпадение будет точное или нет
точное, только что в начальной что в конечной ячейках может быть несколько значений с разделителем ","
 
Точное совпадение это когда в одной ячейке "К9" и в другой тоже "К9", а не "К9, К10, К11"
И ещё у Вас в одной базе раскладка RU в другой EN. Потому ваши К9 <> K9
 
Цитата
написал:
RU в другой EN
это я исправлю
 
Попробуйте так
Код
=ЕСЛИ(F3="Бетонирование бетонной  подготовки";ИНДЕКС([ВедомостьОбъемов.xlsx]Бетон!$A$3:$V$11;ПОИСКПОЗ("*"&H3&",*";[ВедомостьОбъемов.xlsx]Бетон!$A$3:$A$11&",";0);22);ЕСЛИ(F3="Бетонирование плиты днища";ИНДЕКС([ВедомостьОбъемов.xlsx]Бетон!$A$3:$V$11;ПОИСКПОЗ("*"&H3&",*";[ВедомостьОбъемов.xlsx]Бетон!$A$3:$A$11&",";0);19);ЕСЛИ(F3="Бетонирование стен";ИНДЕКС([ВедомостьОбъемов.xlsx]Бетон!$A$3:$V$11;ПОИСКПОЗ("*"&H3&",*";[ВедомостьОбъемов.xlsx]Бетон!$A$3:$A$11&",";0);20);"Не найдено")))

Только придется разбить ячейку "К10, К8" и "К18, К19" на отдельные ячейки
Изменено: Msi2102 - 29.04.2022 15:34:26
 
Цитата
написал:
Попробуйте так
спасибо
но нужен код VBA
это лишь малая часть условий и одна из таблиц для поиска значений, и так много в формулу будет проблематично писать))
нужен код который потом копировать, и менять условия и ссылки на файлы для поиска данных


вот что смог сам сделать))
только не работает так как надо... берет последнее значение
как я понял это можно решить через массив, только чуть-чуть не получается))
Код
Sub ЗаполнитьОбъемы()
Dim lLastRowBeton, lLastRowBazaAktov As Long
Dim L1, n, st1 As Variant
Application.ScreenUpdating = False
    PathAktov = ActiveWorkbook.Path
   
Dim firstBook, secondBook As Workbook
Set firstBook = ActiveWorkbook
On Error Resume Next
Set secondBook = Workbooks.Open(ActiveWorkbook.Path & "\сводная ведость объемов.xlsm")
On Error GoTo 0
lLastRowBazaAktov = firstBook.Sheets("БазаАктов").Cells(Rows.Count, 6).End(xlUp).End(xlUp).row
lLastRowBeton = secondBook.Sheets("камеры_бетон").Cells(3, 1).End(xlDown).row
For X = 3 To lLastRowBeton - 1
   st1 = Split(secondBook.Sheets("камеры_бетон").Cells(X, 1), ",")
   L1 = UBound(st1)
   For Y = 4 To lLastRowBazaAktov
        If firstBook.Sheets("БазаАктов").Cells(Y, 6) = "Бетонирование бетонной  подготовки" Then
            For z = 4 To lLastRowBeton
                For n = 0 To L1
                   If secondBook.Sheets("камеры_бетон").Cells(z, 1) Like st1(n) Then
                     firstBook.Sheets("БазаАктов").Cells(Y, 12) = secondBook.Sheets("камеры_бетон").Cells(z, 22)
                   End If
                Next n
            Next z
        End If
   Next Y
Next X
Application.ScreenUpdating = True
End Sub
Изменено: narod svs - 29.04.2022 15:40:33
 
Попробуйте так
Код
Sub Макрос1()
    Dim arr As Variant, arr1 As Variant, arr2 As Variant, lr As Long, n As Long, m As Long
    lr = Workbooks("ВедомостьОбъемов.xlsx").Sheets("Бетон").Cells(Rows.Count, 1).End(xlUp).Row
    arr1 = Workbooks("ВедомостьОбъемов.xlsx").Sheets("Бетон").Range("A3:V" & lr)
    lr = ThisWorkbook.Sheets("Реестр").Cells(Rows.Count, 1).End(xlUp).Row
    arr = ThisWorkbook.Sheets("Реестр").Range("A3:L" & lr)
    ReDim arr2(LBound(arr) To UBound(arr), 1 To 1)
    Set Reg = CreateObject("VBScript.RegExp")
    For n = LBound(arr) To UBound(arr)
        Reg.Pattern = Replace(Join(Split(arr(n, 8), ","), ",|"), " ", "") & ","
        For m = LBound(arr1) To UBound(arr1)
            If Reg.Test(arr1(m, 1) & ",") Then
                If arr(n, 6) = "Бетонирование бетонной  подготовки" Then
                    arr2(n, 1) = arr1(m, 22)
                ElseIf arr(n, 6) = "Бетонирование плиты днища" Then
                    arr2(n, 1) = arr1(m, 19)
                ElseIf arr(n, 6) = "Бетонирование стен" Then
                    arr2(n, 1) = arr1(m, 20)
                Else
                    arr2(n, 1) = "Не найдено"
                End If
                Exit For
            End If
        Next m
    Next n
    ThisWorkbook.Sheets("Реестр").Range("O3:O" & lr) = arr2
End Sub
Изменено: Msi2102 - 29.04.2022 16:34:14
 
Цитата
написал:
Попробуйте так
запускаю и ничего не происходит
 
Желтые ячейки очистите перед запуском
PS: Забыл написать, если в ячейках где есть сдвоенные данные найдется хоть одно значение ("К10 или К8"), то будет проставлено значение
Изменено: Msi2102 - 29.04.2022 17:06:35
 
Цитата
написал:
PS: Забыл написать, если в ячейках где есть сдвоенные данные найдется хоть одно значение ("К10 или К8"), то будет проставлено значение
спасибо
 
Помогите, пожалуйста
Добавил массив arr3 для поиска значений (строки кода 6,11,12,31-38)
Но что то не так.... подскажите где ошибка
Код
Sub ЗаполнитьОбъемы()
    Dim arr, arr1, arr2, arr3 As Variant
    Dim lr, lr1, lr2, lr3, n, m, k As Long
    Set Baza = ThisWorkbook.Sheets("БазаАктов")
    Set Beton = Workbooks("сводная ведость объемов.xlsm").Sheets("камеры_бетон")
    Set Catlovan = Workbooks("сводная ведость объемов.xlsm").Sheets("камера_катлован")
    lr = Baza.Cells(Rows.Count, 1).End(xlUp).row
    arr = Baza.Range("A4:L" & lr)
    lr1 = Beton.Cells(Rows.Count, 1).End(xlUp).row
    arr1 = Beton.Range("A3:V" & lr1)
    lr3 = Catlovan.Cells(Rows.Count, 1).End(xlUp).row
    arr3 = Catlovan.Range("A2:Q" & lr1)
    ReDim arr2(LBound(arr) To UBound(arr), 1 To 1)
    Set Reg = CreateObject("VBScript.RegExp")
    For n = LBound(arr) To UBound(arr)
        Reg.Pattern = Replace(Join(Split(arr(n, 8), ","), ",|"), " ", "") & ","
        For m = LBound(arr1) To UBound(arr1)
            If Reg.Test(arr1(m, 1) & ",") Then
                If arr(n, 6) = "Бетонирование бетонной  подготовки" Then
                    arr2(n, 1) = arr1(m, 22)
                ElseIf arr(n, 6) = "Бетонирование плиты днища" Then
                    arr2(n, 1) = arr1(m, 19)
                ElseIf arr(n, 6) = "Бетонирование стен" Then
                    arr2(n, 1) = arr1(m, 20)
                'Else
                '    arr2(n, 1) = ""
                End If
                Exit For
            End If
        Next m
        For k = LBound(arr3) To UBound(arr3)
            If Reg.Test(arr3(k, 1)) Then
                If arr(n, 6) = "Разработка грунта с уплотнением основания" Then
                    arr2(n, 1) = arr3(k, 17)
                End If
                Exit For
            End If
        Next k
    Next n
    Baza.Range("L4:L" & lr) = arr2
End Sub
Изменено: narod svs - 04.05.2022 08:28:28
 
Вы пример прикладывайте, а то не понятно, что именно Вам нужно. Попробую угадать
Код
Sub ЗаполнитьОбъемы()
    Dim arr, arr1, arr2, arr3 As Variant
    Dim lr, lr1, lr2, lr3, n, m, k As Long
    Set Baza = ThisWorkbook.Sheets("БазаАктов")
    Set Beton = Workbooks("сводная ведость объемов.xlsm").Sheets("камеры_бетон")
    Set Catlovan = Workbooks("сводная ведость объемов.xlsm").Sheets("камера_катлован")
    lr = Baza.Cells(Rows.Count, 1).End(xlUp).row
    arr = Baza.Range("A4:L" & lr)
    lr1 = Beton.Cells(Rows.Count, 1).End(xlUp).row
    arr1 = Beton.Range("A3:V" & lr1)
    lr3 = Catlovan.Cells(Rows.Count, 1).End(xlUp).row
    arr3 = Catlovan.Range("A2:Q" & lr1)
    ReDim arr2(LBound(arr) To UBound(arr), 1 To 1)
    Set Reg = CreateObject("VBScript.RegExp")
    For n = LBound(arr) To UBound(arr)
        Reg.Pattern = Replace(Join(Split(arr(n, 8), ","), ",|"), " ", "") & ","
        For m = LBound(arr1) To UBound(arr1)
            If Reg.Test(arr1(m, 1) & ",") Then
                If arr(n, 6) = "Бетонирование бетонной  подготовки" Then
                    arr2(n, 1) = arr1(m, 22)
                ElseIf arr(n, 6) = "Бетонирование плиты днища" Then
                    arr2(n, 1) = arr1(m, 19)
                ElseIf arr(n, 6) = "Бетонирование стен" Then
                    arr2(n, 1) = arr1(m, 20)
                'Else
                '    arr2(n, 1) = ""
                End If
                Exit For
            End If
        Next m
    Next n
    For n = LBound(arr) To UBound(arr)
        Reg.Pattern = Replace(Join(Split(arr(n, 8), ","), ",|"), " ", "") & ","
        For k = LBound(arr3) To UBound(arr3)
            If Reg.Test(arr3(k, 1) & ",") Then
                If arr(n, 6) = "Разработка грунта с уплотнением основания" Then
                    arr2(n, 1) = arr3(k, 17)
                End If
                Exit For
            End If
        Next k
    Next n
    Baza.Range("L4:L" & lr) = arr2
End Sub


Хотя с первого взгляда должен работать и как у Вас написано, проверьте раскладку, и правильность написания "Разработка грунта с уплотнением основания" в обеих базах, а также возможно не тот адрес вводите "Reg.Test(arr3(k, 1))",
По моему нашёл причину, замените в своем коде:
Код
If Reg.Test(arr3(k, 1)) Then

на
Код
If Reg.Test(arr3(k, 1) & ",") Then
Изменено: Msi2102 - 04.05.2022 09:22:01
 
по некоторым позициям не находит
 
Сделайте так
Код
Sub ЗаполнитьОбъемы()
    Dim arr, arr1, arr2, arr3 As Variant
    Dim lr, lr1, lr2, lr3, n, m, k As Long
    Set Baza = ThisWorkbook.Sheets("БазаАктов")
    Set Beton = Workbooks("сводная ведость объемов.xlsx").Sheets("камеры_бетон")
    Set Catlovan = Workbooks("сводная ведость объемов.xlsx").Sheets("Лист1")
    lr = Baza.Cells(Rows.Count, 1).End(xlUp).Row
    arr = Baza.Range("A3:L" & lr)
    lr1 = Beton.Cells(Rows.Count, 1).End(xlUp).Row
    arr1 = Beton.Range("A3:V" & lr1)
    lr3 = Catlovan.Cells(Rows.Count, 1).End(xlUp).Row
    arr3 = Catlovan.Range("A2:Q" & lr3)
    ReDim arr2(LBound(arr) To UBound(arr), 1 To 1)
    Set Reg = CreateObject("VBScript.RegExp")
    For n = LBound(arr) To UBound(arr)
        Reg.Pattern = Replace(Join(Split(arr(n, 8), ","), ",|"), " ", "") & ","
        For m = LBound(arr1) To UBound(arr1)
            If Reg.Test(arr1(m, 1) & ",") Then
                If arr(n, 6) = "Бетонирование бетонной  подготовки" Then
                    arr2(n, 1) = arr1(m, 22)
                ElseIf arr(n, 6) = "Бетонирование плиты днища" Then
                    arr2(n, 1) = arr1(m, 19)
                ElseIf arr(n, 6) = "Бетонирование стен" Then
                    arr2(n, 1) = arr1(m, 20)
                'Else
                '    arr2(n, 1) = ""
                End If
                Exit For
            End If
        Next m
        For k = LBound(arr3) To UBound(arr3)
            If Reg.Test(arr3(k, 1) & ",") Then
                If arr(n, 6) = "Разработка грунта с уплотнением основания" Then
                    arr2(n, 1) = arr3(k, 17)
                End If
                Exit For
            End If
        Next k
    Next n
    Baza.Range("L3:L" & lr) = arr2
End Sub
Изменено: Msi2102 - 04.05.2022 10:37:19
 
спасибо
 
у меня изначально, в посте #12, вроде так и было написано))
 
Цитата
narod svs написал:
у меня изначально, в посте #12, вроде так и было написано))
Если бы всё было так написано, то всё бы работало. Вы изначально делайте правильные примеры. Мне кажется, что при таких условиях так будет правильнее
Код
Sub ЗаполнитьОбъемы()
    Dim arr, arr1, arr2, arr3 As Variant
    Dim lr, lr1, lr2, lr3, n, m As Long
    Dim v As Byte, k As Byte
    Set Baza = ThisWorkbook.Sheets("БазаАктов")
    Set Beton = Workbooks("сводная ведость объемов.xlsx").Sheets("камеры_бетон")
    Set Catlovan = Workbooks("сводная ведость объемов.xlsx").Sheets("Лист1")
    lr = Baza.Cells(Rows.Count, 1).End(xlUp).Row
    arr = Baza.Range("A3:L" & lr)
    lr1 = Beton.Cells(Rows.Count, 1).End(xlUp).Row
    arr1 = Beton.Range("A3:V" & lr1)
    lr3 = Catlovan.Cells(Rows.Count, 1).End(xlUp).Row
    arr2 = Catlovan.Range("A2:Q" & lr3)
    ReDim arr0(LBound(arr) To UBound(arr), 1 To 1)
    Set Reg = CreateObject("VBScript.RegExp")
    For n = LBound(arr) To UBound(arr)
        Reg.Pattern = Replace(Join(Split(arr(n, 8), ","), ",|"), " ", "") & ","
        If arr(n, 6) = "Бетонирование бетонной  подготовки" Then
            v = 1: k = 22
        ElseIf arr(n, 6) = "Бетонирование плиты днища" Then
            v = 1: k = 19
        ElseIf arr(n, 6) = "Бетонирование стен" Then
            v = 1: k = 20
        ElseIf arr(n, 6) = "Разработка грунта с уплотнением основания" Then
            v = 2: k = 17
        End If
        If v = 1 Then
            For m = LBound(arr1) To UBound(arr1)
                If Reg.Test(arr1(m, 1) & ",") Then
                    arr0(n, 1) = arr1(m, k)
                    Exit For
                End If
            Next m
        ElseIf v = 2 Then
            For m = LBound(arr2) To UBound(arr2)
                If Reg.Test(arr2(m, 1) & ",") Then
                    arr0(n, 1) = arr2(m, k)
                    Exit For
                End If
            Next m
        End If
    Next n
    Baza.Range("L3:L" & lr) = arr0
End Sub
Изменено: Msi2102 - 04.05.2022 11:04:45
 
еще раз спасибо... :D  
 
Так будет ещё правильнее
Код
Sub ЗаполнитьОбъемы()
    Dim arr, arr1, arr2, arr3 As Variant
    Dim lr, lr1, lr2, lr3, n, m As Long
    Dim v As Byte, k As Byte
    Set Baza = ThisWorkbook.Sheets("БазаАктов")
    Set Beton = Workbooks("сводная ведость объемов.xlsx").Sheets("камеры_бетон")
    Set Catlovan = Workbooks("сводная ведость объемов.xlsx").Sheets("Лист1")
    lr = Baza.Cells(Rows.Count, 1).End(xlUp).Row
    arr = Baza.Range("A3:L" & lr)
    lr1 = Beton.Cells(Rows.Count, 1).End(xlUp).Row
    arr1 = Beton.Range("A3:V" & lr1)
    lr3 = Catlovan.Cells(Rows.Count, 1).End(xlUp).Row
    arr2 = Catlovan.Range("A2:Q" & lr3)
    ReDim arr0(LBound(arr) To UBound(arr), 1 To 1)
    Set Reg = CreateObject("VBScript.RegExp")
    For n = LBound(arr) To UBound(arr)
        Reg.Pattern = Replace(Join(Split(arr(n, 8), ","), ",|"), " ", "") & ","
        If arr(n, 6) = "Бетонирование бетонной  подготовки" Then
            v = 1: k = 22
        ElseIf arr(n, 6) = "Бетонирование плиты днища" Then
            v = 1: k = 19
        ElseIf arr(n, 6) = "Бетонирование стен" Then
            v = 1: k = 20
        ElseIf arr(n, 6) = "Разработка грунта с уплотнением основания" Then
            v = 2: k = 17
        Else
            v = 0: k = 0
        End If
        If v = 1 Then
            For m = LBound(arr1) To UBound(arr1)
                If Reg.Test(arr1(m, 1) & ",") Then
                    arr0(n, 1) = arr1(m, k)
                    Exit For
                End If
            Next m
        ElseIf v = 2 Then
            For m = LBound(arr2) To UBound(arr2)
                If Reg.Test(arr2(m, 1) & ",") Then
                    arr0(n, 1) = arr2(m, k)
                    Exit For
                End If
            Next m
        Else
            arr0(n, 1) = "Не найдено"
        End If
    Next n
    Baza.Range("L3:L" & lr) = arr0
End Sub
Изменено: Msi2102 - 04.05.2022 12:27:10
 
А возможно в названии массива использовать комбинированное имя с переменной?
типа "arr"&v вместо arr1 когда переменная v=1
Код
            If v = 1 Then
            For m = LBound(arr1) To UBound(arr1)
                If Reg.Test(arr1(m, 1) & ",") Then
                    arr0(n, 1) = arr1(m, k)
                    Exit For
                End If
            Next m
            End If
 
нельзя
читайте "VBA для чайников", раздел "обьявление и использование переменных"
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
спасибо за ответ
 
Цитата
narod svs: использовать комбинированное имя с переменной типа "arr"&v вместо arr1?
нельзя
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
narod svs, Если есть большое желание оставить только один цикл, то можно сделать так:
Код
Sub ЗаполнитьОбъемы()
    Dim arr, arr1, arr2, arr3, arrN(1, 1) As Variant
    Dim lr, lr1, lr2, lr3, n, m As Long
    Dim v As Byte, k As Byte
    Set Baza = ThisWorkbook.Sheets("БазаАктов")
    Set Beton = Workbooks("сводная ведость объемов.xlsx").Sheets("камеры_бетон")
    Set Catlovan = Workbooks("сводная ведость объемов.xlsx").Sheets("Лист1")
    lr = Baza.Cells(Rows.Count, 1).End(xlUp).Row
    arr = Baza.Range("A3:L" & lr)
    lr1 = Beton.Cells(Rows.Count, 1).End(xlUp).Row
    arr1 = Beton.Range("A3:V" & lr1)
    lr3 = Catlovan.Cells(Rows.Count, 1).End(xlUp).Row
    arr2 = Catlovan.Range("A2:Q" & lr3)
    ReDim arr0(LBound(arr) To UBound(arr), 1 To 1)
    Set Reg = CreateObject("VBScript.RegExp")
    
    Set dic = CreateObject("Scripting.Dictionary")
    dic.Add 0, arrN
    dic.Add 1, arr1
    dic.Add 2, arr2

    For n = LBound(arr) To UBound(arr)
        Reg.Pattern = Replace(Join(Split(arr(n, 8), ","), ",|"), " ", "") & ","
        If arr(n, 6) = "Бетонирование бетонной  подготовки" Then
            v = 1: k = 22
        ElseIf arr(n, 6) = "Бетонирование плиты днища" Then
            v = 1: k = 19
        ElseIf arr(n, 6) = "Бетонирование стен" Then
            v = 1: k = 20
        ElseIf arr(n, 6) = "Разработка грунта с уплотнением основания" Then
            v = 2: k = 17
        Else
            v = 0: k = 0
        End If
  
        vv = dic.Item(v)
        arr0(n, 1) = "Не найдено"
        For m = LBound(vv) To UBound(vv)
            If Reg.Test(vv(m, 1) & ",") Then
                arr0(n, 1) = vv(m, k)
                Exit For
            End If
        Next m
        
    Next n
    Baza.Range("L3:L" & lr) = arr0
End Sub
 
Msi2102, спасибо большое, то что нужно
 
Msi2102,
Можно удобнее ветвить в данном случае  ;)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
Jack Famous написал:
Можно удобнее ветвить в данном случае  
Согласен, но это дело привычки, да и неизвестно знаком такой синтаксис для ТС, потом объяснять нужно, а мне лень  :D
 
Цитата
написал:
Можно удобнее ветвить в данном случае  
Спасибо)) изящно... гораздо читабельнее чем If.. Elso..
Код
        Select Case arr(n, 6)
            Case "Бетонирование бетонной  подготовки":          v = 1: k = 22
            Case "Бетонирование плиты днища":                   v = 1: k = 19
            Case "Бетонирование стен":                          v = 1: k = 20
            Case "Разработка грунта с уплотнением основания"
                Select Case arr(n, 15)
                    Case "камера":                              v = 2: k = 18
                    Case "колодец":                             v = 3: k = 12
                End Select
            Case Else:                                          v = 0: k = 0
        End Select
 
Цитата
написал:
ТС
знать не знал такой аббревиатуры)) теперь знаю)) спасибо за помощь
Страницы: 1 2 След.
Наверх