如何在Task Allocation环节用VBA实现自动更新

yrongyyf

示例数据.xlsx
之前一直用Vlookup手动更新但是不是特别方便，需求如下：
1、首先根据Sheet1里的Status进行更新，如果状态为Renewal，则不增加新行，在原有Project基础上进行更新；如果状态为New，则新增一行并在对应位置加上项目Project Num。
2、其次，再扫描每一列的列名如果在Sheet2里有的（如Project Num等），则进行更新（类似用Vlookup根据项目ID，进行地抓取）。
求大佬帮忙看看，感谢！

Mengkelyu

首先表扬提问格式！终于能看到一个清晰+有示例的问题了。搞了一下代码，有时间来解释。

注意我把Sheet1的"A1"命名为了"Start"，Sheet2的"A1"命名为了"Start2"

Option Explicit
Option Base 1

Sub Main()

Dim Mapping_Table, Output_Table, Mapping_Header, Output_Header As Variant

'输入检查'

If Range("Start").CurrentRegion.Rows.Count = 1 Then
           MsgBox "You have to input at least one row in Sheet 1!"
           Exit Sub
End If

With Range("Start").CurrentRegion
    Mapping_Table = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Value
    Mapping_Header = .Resize(1, .Columns.Count).Value
End With

Dim existingRows As Long



If Range("Start2").CurrentRegion.Rows.Count = 1 Then
           Output_Table = Array(0, 0, 0)
Else
        With Range("Start2").CurrentRegion
            existingRows = .Rows.Count - 1
            Output_Table = .Offset(1, 0).Resize(10000, .Columns.Count).Value
            Output_Header = .Resize(1, .Columns.Count).Value
        End With
End If

Dim i As Integer, j As Integer, k As Integer, cnt As Integer

For i = 1 To UBound(Mapping_Table, 1)

    If Mapping_Table(i, 2) = "Renewal" Then
            cnt = 0
            For j = 1 To existingRows
                       If Mapping_Table(i, 1) = Output_Table(j, 1) Then
                            cnt = 1
                            For k = 1 To UBound(Mapping_Table, 2)
                                   Output_Table(j, MatchRowArrLoc(Output_Header, Mapping_Header(1, k))) = Mapping_Table(i, k)
                            Next k
                        End If
            Next j
            If cnt = 0 Then MsgBox "Error on row i"
    ElseIf Mapping_Table(i, 2) = "New" Then
            existingRows = existingRows + 1
            For k = 1 To UBound(Mapping_Table, 2)
                                   Output_Table(existingRows, MatchRowArrLoc(Output_Header, Mapping_Header(1, k))) = Mapping_Table(i, k)
            Next k
    End If

Next

Range("Start2").Offset(1, 0).Resize(UBound(Output_Table, 1), UBound(Output_Table, 2)) = Output_Table

End Sub

'这个Function用来匹配行数组里面的值并返回其序号'

Function MatchRowArrLoc(ByVal ar As Variant, ByVal target) As Integer
Dim i As Integer
For i = 1 To UBound(ar, 2)
        If ar(1, i) = target Then MatchRowArrLoc = i
Next i

End Function

Mengkelyu

1656423090374-示例数据.zip