更新每月数据，如果不存在数据，则需要插入新行

如何解决更新每月数据，如果不存在数据，则需要插入新行

对于excel中的上表（请参阅图片），我正在构建一个Macro以自动更新每月余额。我有1月到12月的数据，为简单起见，我假设只有1月和2月的数据。

通过使用VLOOKUP，我可以将2月余额附加到1月余额的相邻列中。但是，让我担心的是每个月现有客户的新帐户（例如Cell F8中的客户B 2345675555），因为VLOOKUP只会忽略它。我需要复制新客户ID的数据并将其粘贴到现有表下的新行中。请注意，每个客户的帐户数量只会增加。非常感谢您能为我提供解决方案（可通过VBA Macro实现）。

解决方法

实际上，我以为您的“ Jan”工作表就是您的“ Master”工作表，该工作表的标题行中包含所有月份的名称，这些也将是您与之相同的工作簿中工作表的名称。要导入余额。

因此，我想到了一个想法，您可以双击“主”表上的月份名称（名称无关紧要），然后从您单击其名称的表中导入余额（名称​​必须完全匹配） ）添加到您单击的列中。下面的代码正是这样做的。像在VLOOKUP中一样，该工作表列出客户端名称的顺序也不重要。但是新名称将添加在底部。在下一次运行之前，您可以对它们进行不同的排序。与使用VLOOKUP时不同，工作表之间没有永久链接。这是代码。

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range,_
                                        Cancel As Boolean)
    ' 084
    
    Const TriggerRow    As Long = 1         ' change to suit
    
    Dim TabName         As String           ' worksheet name to update from
    Dim WsS             As Worksheet        ' data source: Tabname
    
    With Target
        If .Row = TriggerRow Then           ' skip if row is different
            TabName = .Value
            If Len(TabName) Then            ' if the clicked cell isn't blank
                On Error Resume Next
                Set WsS = Worksheets(TabName)
                If Err Then
                    MsgBox "The worksheet """ & TabName & """ hasn't been set up yet.",_
                           vbInformation,"Invalid tab name"
                Else
                    Application.ScreenUpdating = False      ' this is faster
                    TransferBalances Target,WsS
                    Application.ScreenUpdating = True
                End If
            End If
            Err.Clear
            Cancel = True
        End If
    End With
End Sub

Private Sub TransferBalances(Target As Range,_
                             WsS As Worksheet)
    ' 084
    
    ' the same columns are used in both the Master and all Source sheets
    ' columns need not be positioned in numeric sequence (1 = "A",2="B" etc)
    Const NameClm   As Long = 1         ' specify the column where the Client names are
    Const IdClm     As Long = 2         ' specify the column where the Client IDs are
    Const BalClm    As Long = 3         ' specify the column where the balance are
    
    Dim IdRng       As Range            ' existing IDs in "Master" sheet
    Dim SrcRng      As Range            ' cell range containing source data
    Dim Src         As Variant          ' value of SrcRng (for faster access)
    Dim R           As Long             ' loop counter: Rows
    Dim Rt          As Long             ' target row
    
    With Target.Worksheet
        Set IdRng = .Range(.Cells(1,IdClm),.Cells(.Rows.Count,IdClm).End(xlUp))
        ' the range will not be extended to include added items
    End With
    
    With WsS
        R = .Cells(.Rows.Count,IdClm).End(xlUp).Row        ' last used row (IdClm)
        ' row 2 is the first row with data to be transferred
        ' copy all columns from A to the last one used in row 1
        Set SrcRng = .Range(.Cells(2,1),_
                            .Cells(1,.Columns.Count).End(xlToLeft).Offset(R - 1))
    End With
    Src = SrcRng.Value
    
    For R = 1 To UBound(Src)
        On Error Resume Next
        Rt = WorksheetFunction.Match(Src(R,IdRng,0)
        With Target.Worksheet
            If Err Or (Rt = 1) Then             ' disallow match in header row
                Rt = .Cells(.Rows.Count,IdClm).End(xlUp).Row + 1
                .Rows(Rt - 1).Copy
                .Rows(Rt).Insert Shift:=xlDown  ' copy formats from above
                Application.CutCopyMode = False
                .Cells(Rt,NameClm).Value = Src(R,NameClm)
                .Cells(Rt,IdClm).Value = Src(R,IdClm)
            End If
            .Cells(Rt,Target.Column).Value = Src(R,BalClm)
        End With
    Next R
    Err.Clear
End Sub

由于代码会响应双击事件，因此必须将其安装在主工作表的代码模块中。此位置必不可少，因为在工作簿中的其他任何地方都不会注意到双击。只有将代码粘贴到该模块中，您才能享受到承诺的自动化。