Обновление и добавление строк на основе двух критериев в VBA Excel

Question

Может ли кто-нибудь помочь мне написать код в VBA, который обновляет таблицу или добавляет новые данные на основе критериев в двух столбцах?

Например, может быть столбец имени и столбец проекта, и мы хотим проверить, работал ли Марк над проектом1. Если Марк работал над проектом1, обновите его строку новыми данными из отдельной электронной таблицы. Если Марк работал над проектом 2 в отдельной электронной таблице, но это не задокументировано в исходной электронной таблице, добавьте Mark и project2 вместе с информацией из этой строки. Если Бетти работала над проектом 1, и исходная электронная таблица содержит эту информацию, обновите эту строку. Если Бетти работала над проектом 2, но исходная электронная таблица не содержит этой информации, добавьте ее в качестве новой строки. Таким образом, имена И проекты будут появляться в таблице несколько раз, просто с разными комбинациями.

Таким образом, идея состоит в том, чтобы проверять оба столбца одновременно, обновлять и добавлять новые данные соответственно.

Вот неисправный код, который у меня есть сейчас:

Dim filename As String
Dim ManagerLEs As Workbook
Dim ProjectLEs As Workbook
Set ProjectLEs = ThisWorkbook

filename = Application.GetOpenFilename("Word files (*.xlsx),*.xlsx", , "Browse for file containing table to be imported")

If filename = Empty Then
    Exit Sub
End If

Set ManagerLEs = Application.Workbooks.Open(filename)

Dim first_blank_row As Long
first_blank_row = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row
starting_row = 4

Dim r As Long

r = starting_row

Dim namefound As Range
Dim projectfound As Range

firstname = ManagerLEs.ActiveSheet.Range("a" & r).Value
projectname = ManagerLEs.ActiveSheet.Range("d" & r).Value

Do While firstname <> 0

Set namefound = Columns("a:a").Find(what:=firstname, LookIn:=xlValues, lookat:=xlWhole)
Set projectfound = Columns("d:d").Find(what:=projectname, LookIn:=xlValues, lookat:=xlWhole)

    'look for current ticket number in main file
    If (namefound Is Nothing And projectfound Is Nothing) Then

        'add info to end of main file
        For c = 1 To 57
        ProjectLEs.Worksheets("Template").Cells(first_blank_row, c) = ManagerLEs.Worksheets("LEs").Cells(r, c)
        first_blank_row = first_blank_row + 1
        Next c
    Else

        'overwrite existing line of main file
        For c = 1 To 57
        ProjectLEs.Worksheets("Template").Cells(namefound.Row, c) = ManagerLEs.Worksheets("LEs").Cells(r, c)
        Next c
    End If

        r = r + 1
        firstname = ManagerLEs.ActiveSheet.Range("a" & r).Value
        projectname = ManagerLEs.ActiveSheet.Range("d" & r).Value
Loop

Спасибо!

Answer 1

Я бы использовал Power Query Add-In для этого типа требований. Он имеет много функций для преобразования данных, включая слияние и добавление. Вы строите свой запрос в визуальном интерфейсе, нажимая кнопки (он генерирует код) и можете видеть полученные данные на каждом шаге.

https://support.office.com/en-us/article/Microsoft-Power-Query-for-Excel-Help-2b433a85-ddfb-420b-9cda-fe0e60b82a94?ui=en-US&rs=en-001&ad=US

Answer 2

Пробовал этот код, не работает.

Sub importLEs()

With Excel.Application
    .ScreenUpdating = False
    .Calculation = Excel.xlCalculationManual
    .EnableEvents = False
End With

Dim filename As String
Dim ManagerLEs As Workbook
Dim ProjectLEs As Workbook
Set ProjectLEs = ThisWorkbook

'open file that you are importing data from
filename = Application.GetOpenFilename("Word files (*.xlsx),*.xlsx", , "Browse for file containing table to be imported")

If filename = Empty Then
    Exit Sub
End If

Set ManagerLEs = Application.Workbooks.Open(filename)

Dim first_blank_row As Long

first_blank_row = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
starting_row = 4

Dim r As Long
Dim rr As Long

r = starting_row
rr = 4

firstname = ManagerLEs.ActiveSheet.Range("a" & r).Value
projectname = ManagerLEs.ActiveSheet.Range("d" & r).Value
mastername = ProjectLEs.Worksheets("Template").Range("a" & rr).Value
masterproject = ProjectLEs.Worksheets("Template").Range("d" & rr).Value

Do While firstname <> 0

    'counter to check if a row is updated
    flag = False

    Do While mastername <> 0

        If mastername = firstname And masterproject = projectname Then

            'update existing line of main file
            For c = 10 To 57
            ProjectLEs.Worksheets("Template").Cells(rr, c) = ManagerLEs.Worksheets("LEs").Cells(r, c)
            Next c
            flag = True
            Exit Do

        End If

    Loop

        'if data does not exist, append data to the end of main file
        If flag = False Then

            For c = 1 To 57
            ProjectLEs.Worksheets("Template").Cells(first_blank_row, c) = ManagerLEs.Worksheets("LEs").Cells(r, c)
            Next c

        End If

        first_blank_row = first_blank_row + 1
        rr = rr + 1
        r = r + 1
        firstname = ManagerLEs.ActiveSheet.Range("a" & r).Value
        projectname = ManagerLEs.ActiveSheet.Range("d" & r).Value
        mastername = ProjectLEs.Worksheets("Template").Range("a" & rr).Value
        masterproject = ProjectLEs.Worksheets("Template").Range("d" & rr).Value

Loop

With Excel.Application
    .ScreenUpdating = True
    .Calculation = Excel.xlAutomatic
    .EnableEvents = True
End With

End Sub

Нужна немного больше помощи.