时间戳

首页 > 解决方案 > 如果已经存在，则覆盖正在发送到表的数据？

excel - 如果已经存在，则覆盖正在发送到表的数据？

问题描述

我有一个脚本，可以将数据从用户窗体发送到网络驱动器上的表。我还有代码将表格数据填充回表单中，供用户进行编辑。假设我有一个现有条目，提取数据进行更新，如何确保它覆盖已经存在的条目而不是附加额外的行？我可以执行一个 if 语句来检查它是否已经存在吗？

编辑代码：

Private Sub cmdSendData_Click()

    Set wb = Workbooks.Open("\\\OFFER_LOG_DATA_TABLE.xlsx")
    Dim wsTgt As Worksheet: Set wsTgt = wb.Worksheets("Sheet1")
    Dim recRow As Range

    'See if there's a match on an existing row
    '  adjust function to suit...
    Set recRow = MatchRow(wsTgt.Range("A1").CurrentRegion, _
                          txtCandidateName.Text, _
                          txtCurrentPosition.Text)

    'If there's no existing row to update then add a new row at the bottom
    If recRow Is Nothing Then Set recRow = wsTgt.Range("A50000").End(xlUp).Offset(1, 0)

    With recRow.EntireRow
        .Cells(1).Value = txtTodays_Date.Text 'section 1
        .Cells(2).Value = Me.cmbReason_for_Offer.Value
        .Cells(33).Value = txtMgrJustification.Text
    End With
        
    
    wb.Close savechanges:=True
    Application.Quit   '????
    wb.Saved = True
        
End Sub

'Return a row from a table based on matches in two columns
'   returns nothing if no match
Function MatchRow(tableRange As Range, lStore, lName) As Range
    Dim rw As Range
    lStore = Me.txtStore.Text
    lName = Me.txtCandidateName.Text
    For Each rw In tableRange.Rows
        'adjust the column numbers/match types as needed
        If rw.Cells(4).Value = lStore Then
            If rw.Cells(16).Value = lName Then
                Set MatchRow = rw
                Exit Function
            End If
        End If
    Next rw
End Function

标签： excelvbauserform

解决方案

应该看起来像这样：

Private Sub cmdSendData_Click()

    Set wb = Workbooks.Open("\\TABLE.xlsx")
    Dim wsTgt As Worksheet: Set wsTgt = wb.Worksheets("Sheet1")
    Dim recRow As Range 

    'See if there's a match on an existing row
    '  adjust function to suit...
    Set recRow = MatchRow(wsTgt.Range("A1").CurrentRegion, _
                          txtCandidateName.Text, _
                          txtCurrentPosition.Text)

    'If there's no existing row to update then add a new row at the bottom 
    If recRow is nothing then set recRow = wsTgt.Range("A50000").End(xlUp).Offset(1, 0)

    With recRow.EntireRow          
        .cells(1).Value = txtTodays_Date.Text 'section 1
        .cells(2).Value = Me.cmbReason_for_Offer.Value
        '....
        .cells(33).Value = txtMgrJustification.Text
    End With
        
    
    wb.Close savechanges:=True
    Application.Quit   '????
    wb.Saved = True
        
End Sub

'Return a row from a table based on matches in two columns
'   returns nothing if no match
Function MatchRow(tableRange As Range, match1, match2) As Range
    Dim rw As Range
    For Each rw In tableRange.Rows
        'adjust the column numbers/match types as needed
        If rw.Cells(1).Value = match1 Then
            If rw.Cells(3).Value = match2 Then
                Set MatchRow = rw
                Exit Function
            End If
        End If
    Next rw
End Function

无论您必须加载现有记录的任何代码都应该跟踪它来自哪一行，否则您将需要一些方法来在以后保存记录时重新找到该行。

推荐阅读