Поиск всех значений по условию из одной таблицы в другой.

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Поиск всех значений по условию из одной таблицы в другой. (Макросы/Sub)

ASASSIN

Дата: Воскресенье, 03.10.2021, 05:41 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 2

Репутация: 0 ±

Замечаний: 0% ±

Добрый день, уважаемые форумчане. Суть вопроса в следующем В общем каждый день присылают несколько файлов с обновлённой информацией по каждой линии (столбец E:E файл сводник). Конкретно интересуют столбцы (файл СВОДНИК- T:T , U:U , AF:AF , AG:AG , AL:AL , AM:AM дата и статус). Мне нужно в мою таблицу (Insulation LOG) перетягивать статусы и даты с таблицы (СВОДНИК) по критерию номера линии (столбец E:E). Формульные варианты не подходят так как информации очень много. Спасибо. Использую следующий код для поиска значений в столбце E из таблицы Insulation log, в таблице Сводник, и при нахождении скопировать значение из столбца со статусами U:U в таблицу Insulation log. Как не пробовал, результат получается разный либо 2 строки целиком копируются либо ни одной
[vba]

Код

Sub poisk_v()
Dim WbFROM, WbTO As Excel.Workbook
Dim ShFROM, ShTO As Excel.Worksheet
Dim RFound As Range
Dim strSelect, FirstFind As String
Dim SPath As String
Application.ScreenUpdating = False
Application.EnableEvents = False

SPath = "C:\Users\HP-PK\Desktop\Ñåòåâàÿ ïàïêà\2. ÎÁÙ. ÑÂÎÄÍÈÊ Ô-2.xlsb"
Set WbFROM = Workbooks.Open(SPath)
Set ShFROM = WbFROM.Worksheets("Main")
Set WbTO = ThisWorkbook
Set ShTO = ThisWorkbook.Worksheets("LOG")

strSelect = Range("E2:E50000").Value

With ShFROM
Set RFound = .Columns(5).Find(strSelect, LookIn:=xlValues)
If Not RFound Is Nothing Then
FirstFind = RFound.Address
Do
.Range(.Cells(RFound.Row, 1), .Cells(RFound.Row, _
.Cells(RFound.Row, .Columns.Count).End(xlToLeft).Column)).Copy
ShTO.Cells(ShTO.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteAll
Set RFound = .Columns(20).Find(strSelect, LookIn:=xlValues, After:=.Range(RFound.Address))
Loop While FirstFind <> RFound.Address
End If
End With
WbFROM.Close
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

[/vba]

Код

[/vba]ASASSIN

К сообщению приложен файл: Insulation_LOG.xlsx (10.5 Kb) · 8217155.xlsx (11.5 Kb)

Сообщение отредактировал ASASSIN - Воскресенье, 03.10.2021, 07:19

Ответить

СообщениеДобрый день, уважаемые форумчане. Суть вопроса в следующем В общем каждый день присылают несколько файлов с обновлённой информацией по каждой линии (столбец E:E файл сводник). Конкретно интересуют столбцы (файл СВОДНИК- T:T , U:U , AF:AF , AG:AG , AL:AL , AM:AM дата и статус). Мне нужно в мою таблицу (Insulation LOG) перетягивать статусы и даты с таблицы (СВОДНИК) по критерию номера линии (столбец E:E). Формульные варианты не подходят так как информации очень много. Спасибо. Использую следующий код для поиска значений в столбце E из таблицы Insulation log, в таблице Сводник, и при нахождении скопировать значение из столбца со статусами U:U в таблицу Insulation log. Как не пробовал, результат получается разный либо 2 строки целиком копируются либо ни одной
[vba]

Код

[/vba]

Автор - ASASSIN
Дата добавления - 03.10.2021 в 05:41

doober

Дата: Воскресенье, 03.10.2021, 13:00 | Сообщение № 2

Группа: Друзья

Ранг: Ветеран

Сообщений: 970

Репутация: 332 ±

Замечаний: 0% ±

Excel 2010

Так можно.

[vba]

Код

Sub Update_Log()
    Dim Sh As Worksheet, key As String, res()
    Filename = "C:\Users\HP-PK\Desktop\Naoaaay iaiea\2. IAU. NAIAIEE O-2.xls"
    Set Sh = Workbooks.Open(Filename:=Filename).Worksheets("Main")
    LastRow = Sh.Cells(Sh.Rows.Count, "E").End(xlUp).Row
    dx = Sh.Range("E1:AM" & LastRow)
    Sh.Parent.Close (False)
    Set C_is = CreateObject("scripting.dictionary")
    For n = 3 To UBound(dx)
        key = dx(n, 1)
        If key <> "" Then
            C_is.Item(key) = n
        End If
    Next
    Set Sh = ThisWorkbook.Worksheets("LOG")
    LastRow = Sh.Cells(Sh.Rows.Count, "E").End(xlUp).Row
    dy = Sh.Range("E1:F" & LastRow)
    For n = 2 To UBound(dy)
        key = dy(n, 1)
        If key <> "" Then
            If C_is.Exists(key) Then
                rw = C_is.Item(key)
                ReDim res(1 To 6)
                res(1) = dx(rw, 17)
                If IsDate(dx(rw, 18)) Then
                    res(2) = Format(dx(rw, 18), "dd.MM.yyyy")
                Else
                    res(2) = dx(rw, 18)
                End If
                res(3) = dx(rw, 29)
                If IsDate(dx(rw, 28)) Then
                    res(4) = Format(dx(rw, 28), "dd.MM.yyyy")
                Else
                    res(4) = dx(rw, 28)
                End If
                res(5) = dx(rw, 35)
                If IsDate(dx(rw, 34)) Then
                    res(6) = Format(dx(rw, 34), "dd.MM.yyyy")
                Else
                    res(6) = dx(rw, 34)
                End If

                Sh.Range("s" & n).Resize(1, UBound(res)) = res
            End If
        End If
    Next

End Sub

[/vba]

Так можно.

[vba]

Код