Copy data to another sheet and ask to overwrite if record already exists

N

nuficek

Board Regular
Joined
Jul 20, 2016
Messages
54
Office Version
  1. 365
Platform
  1. Windows
Hi,
I have a form where I'm able to save, search or delete data which are stored on the another sheet. When I store data (based on unique ID) to another sheet it always stores data to the last available row. But I don't know how to check if the record already exists and ask to overwrite it or not.
I have first sheet named "Form" where is unique ID composed from B3 and D3. Then there is many random fields in the form. All fields are stored on the another sheet named "Data Storage" always in the single row starting row 5 as there is a header. So it starts B5 (which matches B3 from sheet "Form") and C5 (which matches D3 from sheet "Form") and then it continuous with the rest fields. So one row is one record with unique IDs B5 and C5.

VBA Code: 
Option Explicit



Public Sub saveForm()

Dim NextRow As Long, Ws As Worksheet

    

    Set Ws = Sheets("Data Storage")

    NextRow = Ws.Cells(Rows.Count, "B").End(xlUp).Row + 1

    Application.ScreenUpdating = False

    

        With Sheets("Form")

        

'       UNIQE ID

        Ws.Range("B" & NextRow).Value = .Range("B3").Value

        Ws.Range("C" & NextRow).Value = .Range("D3").Value

        

'                                  DATA #1

        Ws.Range("D" & NextRow).Value = .Range("B8").Value

        Ws.Range("E" & NextRow).Value = .Range("C8").Value

        Ws.Range("F" & NextRow).Value = .Range("D8").Value

        Ws.Range("G" & NextRow).Value = .Range("E8").Value

        Ws.Range("H" & NextRow).Value = .Range("F8").Value

        Ws.Range("I" & NextRow).Value = .Range("H8").Value

        Ws.Range("J" & NextRow).Value = .Range("I8").Value

        Ws.Range("K" & NextRow).Value = .Range("J8").Value

                

'                                  DATA#2

        Ws.Range("L" & NextRow).Value = .Range("B9").Value

        Ws.Range("M" & NextRow).Value = .Range("C9").Value

        Ws.Range("N" & NextRow).Value = .Range("D9").Value

        Ws.Range("O" & NextRow).Value = .Range("E9").Value

        Ws.Range("P" & NextRow).Value = .Range("F9").Value

        Ws.Range("Q" & NextRow).Value = .Range("H9").Value

        Ws.Range("R" & NextRow).Value = .Range("I9").Value

        Ws.Range("S" & NextRow).Value = .Range("J9").Value



'                                   TOTAL

        Ws.Range("T" & NextRow).Value = .Range("I14").Value

        

'                                   NOTES

        Ws.Range("U" & NextRow).Value = .Range("C27").Value

        

'                                   SIGNATURE DATE

        Ws.Range("V" & NextRow).Value = .Range("C34").Value

        

              

'                                                    .

'                                                    .

'                                                   etc.



End With

    

    Application.ScreenUpdating = True

    MsgBox "Form no. " & Sheets("Form").Range("B3").Value & " " & Sheets("Form").Range("D3").Value & " successfully saved!"

    

End Sub

I would really appreciate help as I'm still new in VBA and doing it just for fun for myself.
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Sort by date Sort by votes
Hi,
Not fully tested - see if this update to your code does what you want

VBA Code: 
Option Explicit

Public Sub SaveForm()
    Dim UniqueID(1 To 2)    As Variant, arr As Variant, m As Variant
    Dim Response            As VbMsgBoxResult
    Dim txtPrompt           As String
    Dim RecordRow           As Long, i As Long
    Dim DataRange           As Range, Cell As Range
    Dim wsDataStorage       As Worksheet, wsForm As Worksheet
    
    With ThisWorkbook
        Set wsDataStorage = .Worksheets("Data Storage")
        Set wsForm = .Worksheets("Form")
    End With
    
    UniqueID(1) = wsForm.Range("B3").Value
    UniqueID(2) = wsForm.Range("D3").Value
    
    'form data entry cells
    Set DataRange = wsForm.Range("B8:F8,H8:J8,B9:F9,H9:J9,I14,C27,C34")
    
    'new record
    RecordRow = wsDataStorage.Cells(wsDataStorage.Rows.Count, "B").End(xlUp).Row + 1
    
    'check record exists
    m = Application.Match(UniqueID(1), wsDataStorage.Columns(2), 0)
    If Not IsError(m) Then
        If wsDataStorage.Cells(m, 3).Value = UniqueID(2) Then
            'inform user
            Response = MsgBox(UniqueID(1) & " " & UniqueID(2) & Chr(10) & _
                       "Record Already Exists" & Chr(10) & _
                       "Do You Want To OverWrite?", 36, "Record Exists")
            If Response = vbNo Then Exit Sub
            'overwrite record
            RecordRow = CLng(m)
            txtPrompt = "Updated"
        End If
     Else
            txtPrompt = "Saved"
    End If
    
    'size array
    ReDim arr(1 To DataRange.Cells.Count)
    For Each Cell In DataRange.Cells
        i = i + 1
        'non-contiguous form cell values to array
        arr(i) = Cell.Value
    Next Cell

    wsDataStorage.Range("B" & RecordRow).Value = UniqueID(1)
    
    wsDataStorage.Range("C" & RecordRow).Value = UniqueID(2)
    
    'post arr to range
    wsDataStorage.Range("D" & RecordRow).Resize(, UBound(arr)).Value = arr
    
    'inform user
    MsgBox "Form no. " & UniqueID(1) & " " & UniqueID(2) & " Successfully " & txtPrompt, 64, "Record " & txtPrompt

    'optional clear form entry
    'DataRange.ClearContents

End Sub

ensure make back-up before testing new code

Dave
 
Upvote 0
Thanks a lot for your reply. But this doesn't work. I'm not sure if it search based on unique ID as combination of values in column B a C in the sheet "Data storage". Because it's only unique when it's combine not each alone.
If I understand code correctly it searches first in the column B and then in column C.
 
Upvote 0
Hi,
solution based on your code where you are posting ID values in columns B & C - code first searches Column B & then checks for match in Column C to combine both values. You gave no example of your ID values so assumed both were numeric?

Suggest either post a copy of your worksheet using MrExcel Addin XL2BB - Excel Range to BBCode
or better still, place copy of your workbook with dummy data in a file sharing site like Dropbox & provide a link to it here.

Dave
 
Upvote 0
Hi,
I may have misunderstood, solution was based on both values in range being unique - If values in Column B are repeated, then a different approach will be needed

Try this update & see if does what you want

VBA Code: 
Option Explicit

Public Sub SaveForm()
    Dim UniqueID(1 To 2)    As Variant, arr() As Variant
    Dim Response            As VbMsgBoxResult
    Dim txtPrompt           As String, FirstAddress As String
    Dim RecordRow           As Long, i As Long
    Dim DataRange           As Range, FoundCell As Range, Cell As Range
    Dim wsDataStorage       As Worksheet, wsForm As Worksheet
 
    With ThisWorkbook
        Set wsDataStorage = .Worksheets("Data Storage")
        Set wsForm = .Worksheets("Form")
    End With
 
    'form data entry cells
    Set DataRange = wsForm.Range("B3,D3,B8:F8,H8:J8,B9:F9,H9:J9,I14,C27,C34")
 
    'check ID values entered
    For i = 1 To 2
        UniqueID(i) = DataRange.Areas(i)
        If Len(UniqueID(i)) = 0 Then Exit Sub
    Next
 
    'new record
    RecordRow = wsDataStorage.Cells(wsDataStorage.Rows.Count, "B").End(xlUp).Row + 1
    txtPrompt = "Saved"
 
    'check record exists
    Set FoundCell = wsDataStorage.Columns(2).Find(UniqueID(1), LookIn:=xlValues, LookAt:=xlWhole)
    If Not FoundCell Is Nothing Then
        FirstAddress = FoundCell.Address
        Do
            If UCase(FoundCell.Offset(, 1).Value) = UCase(UniqueID(2)) Then
                'inform user
                Response = MsgBox(UniqueID(1) & " " & UniqueID(2) & Chr(10) & _
                "Record Already Exists" & Chr(10) & _
                "Do You Want To OverWrite?", 36, "Record Exists")
                If Response = vbNo Then Exit Sub
                'overwrite record
                RecordRow = FoundCell.Row
                txtPrompt = "Updated"
                Exit Do
            End If
            Set FoundCell = wsDataStorage.Columns(2).FindNext(FoundCell)
            If FoundCell Is Nothing Then Exit Do
        Loop Until FoundCell.Address = FirstAddress
    End If
 
    'size array
    ReDim arr(1 To DataRange.Cells.Count)
    i = 0
    For Each Cell In DataRange.Cells
        i = i + 1
        'non-contiguous form cell values to array
        arr(i) = Cell.Value
    Next Cell
 
    'post arr to range
    wsDataStorage.Range("B" & RecordRow).Resize(, UBound(arr)).Value = arr
 
    'inform user
    MsgBox "Form no. " & UniqueID(1) & " " & UniqueID(2) & " Successfully " & txtPrompt, 64, "Record " & txtPrompt
 
    'optional clear form entry
    'DataRange.ClearContents
 
End Sub

Dave
 
Upvote 0
Solution
dmt32 said:
Hi,
I may have misunderstood, solution was based on both values in range being unique - If values in Column B are repeated, then a different approach will be needed

Try this update & see if does what you want

VBA Code: 
Option Explicit

Public Sub SaveForm()
    Dim UniqueID(1 To 2)    As Variant, arr() As Variant
    Dim Response            As VbMsgBoxResult
    Dim txtPrompt           As String, FirstAddress As String
    Dim RecordRow           As Long, i As Long
    Dim DataRange           As Range, FoundCell As Range, Cell As Range
    Dim wsDataStorage       As Worksheet, wsForm As Worksheet
 
    With ThisWorkbook
        Set wsDataStorage = .Worksheets("Data Storage")
        Set wsForm = .Worksheets("Form")
    End With
 
    'form data entry cells
    Set DataRange = wsForm.Range("B3,D3,B8:F8,H8:J8,B9:F9,H9:J9,I14,C27,C34")
 
    'check ID values entered
    For i = 1 To 2
        UniqueID(i) = DataRange.Areas(i)
        If Len(UniqueID(i)) = 0 Then Exit Sub
    Next
 
    'new record
    RecordRow = wsDataStorage.Cells(wsDataStorage.Rows.Count, "B").End(xlUp).Row + 1
    txtPrompt = "Saved"
 
    'check record exists
    Set FoundCell = wsDataStorage.Columns(2).Find(UniqueID(1), LookIn:=xlValues, LookAt:=xlWhole)
    If Not FoundCell Is Nothing Then
        FirstAddress = FoundCell.Address
        Do
            If UCase(FoundCell.Offset(, 1).Value) = UCase(UniqueID(2)) Then
                'inform user
                Response = MsgBox(UniqueID(1) & " " & UniqueID(2) & Chr(10) & _
                "Record Already Exists" & Chr(10) & _
                "Do You Want To OverWrite?", 36, "Record Exists")
                If Response = vbNo Then Exit Sub
                'overwrite record
                RecordRow = FoundCell.Row
                txtPrompt = "Updated"
                Exit Do
            End If
            Set FoundCell = wsDataStorage.Columns(2).FindNext(FoundCell)
            If FoundCell Is Nothing Then Exit Do
        Loop Until FoundCell.Address = FirstAddress
    End If
 
    'size array
    ReDim arr(1 To DataRange.Cells.Count)
    i = 0
    For Each Cell In DataRange.Cells
        i = i + 1
        'non-contiguous form cell values to array
        arr(i) = Cell.Value
    Next Cell
 
    'post arr to range
    wsDataStorage.Range("B" & RecordRow).Resize(, UBound(arr)).Value = arr
 
    'inform user
    MsgBox "Form no. " & UniqueID(1) & " " & UniqueID(2) & " Successfully " & txtPrompt, 64, "Record " & txtPrompt
 
    'optional clear form entry
    'DataRange.ClearContents
 
End Sub

Dave
Click to expand...
Hi Dave,
both unique IDs can contain alpha-numeric strings. I tested your code and it says there is error in the following part:
1644236374891.png
 
Upvote 0
Hi
when you copied updated code did you make any changes to the ranges? If so, does your range still INCLUDE the two addresses where shown?

Rich (BB code): 
'form data entry cells
    Set DataRange = wsForm.Range("B3,D3,B8:F8,H8:J8,B9:F9,H9:J9,I14,C27,C34")

Dave
 
Upvote 0
dmt32 said:
Hi
when you copied updated code did you make any changes to the ranges? If so, does your range still INCLUDE the two addresses where shown?

Rich (BB code): 
'form data entry cells
    Set DataRange = wsForm.Range("B3,D3,B8:F8,H8:J8,B9:F9,H9:J9,I14,C27,C34")

Dave
Click to expand...
Nope, I totally missed these two. I'm sorry, my mistake. It works now! :)
 
Upvote 0
You must log in or register to reply here.

Similar threads

V
  • Question
Excel VBA - How to modify my code to include a command that prints data to PDF
Replies
1
Views
124
VanGirl
V
J
  • Question
How to delete row on two worksheets
Replies
2
Views
323
jdcar
J
hendrikbez
  • Question
Cannot get to edit on my user form with 1 to 5 members on it
Replies
1
Views
86
Anthony47
A
S
  • Question
CSV export to remove column
Replies
1
Views
143
StellarRumble59
S
S
  • Question
Parse data - Overwrite lines with updated data
Replies
0
Views
134
Scifo
S

Forum statistics

Threads
1,215,461
Messages
6,124,955
Members
449,199
Latest member
Riley Johnson

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top