Transfer data from one sheet to another using macro

L

Lux Aeterna

Board Regular
Joined
Aug 27, 2015
Messages
201
Office Version
  1. 2019
Platform
  1. Windows
Hello again!

I have got an excel file that contains two sheets.
The first one, named Appointments, contains demographic data, such as name, age etc.
IDΟνοματεπώνυμοΗλικίαΑΜΚΑΤ.Ε.Ρ.ΥποκατάστημαΗ.Λ.Ε.
1person 1616582145825431/12/2021place A05/05/2022
2person 2613252841296329/12/2021place B07/03/2022
3person 3572147823654129/12/2021place C21/08/2022
4person 4689874336658029/12/2021place D14/01/2022

The second one, named Results, draws these demographic data from the Appointments sheet, through an IF function, using each person's ID.

1658399203285.png


On the same sheet, there are also some cells that allow manual changes to the above data (instead of drawing them from the Appointments sheet. So, if the person who fills in the Results sheet finds a mistake, e.g. in the name, they can edit it.

1658399344134.png


What I would like is to have a macro to transfer those edits to the Appointments sheet as well.

For example, if the name on ID 1 is written as George instead of Gerogia, the person will correct it (using column AA), it will appear on the results form (line 5), but I also want it to change on the Appointments sheet as well, so as not to have to transfer it myself manually.

I'd rather not have an automated process that runs on the background, but a macro that I'll assign a button to it. If that's possible, I can give you the ranges and all other relevant info.

Hope my message makes sense :)🤞🙏
 
Sort by date Sort by votes
sijpie said:
I understood that the correction table needs to be transferred. But I need to know on which row, so that is why I need the information in the results table. But I see there is also an ID in U2, so I can use that to quickly find the correct row.

I will include the overwriting of column B.
Thanks for the info
Click to expand...
Exactly, you can use the ID in cell U2 on the Results sheet to find the correct row on the Appointments sheet.
IDs on the Appointments sheet are in column A. ID 1 is in cell A5, ID 2 in A6 and so on.
 
Upvote 0

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
VBA Code: 
Option Explicit

Sub Transfer_Corrected_Data()
    Dim vCorr As Variant, vOut As Variant, vData As Variant, vRS As Variant
    Dim lRi As Long, lRo As Long, lRd As Long, UBi1 As Long, UBd1 As Long, lC As Long
    Dim wsA As Worksheet, wsR As Worksheet
    Dim rAD As Range, rRS As Range, rCorr As Range
    Dim sIDN As String, vCh As Variant
    Dim vIBR As VbMsgBoxResult
    
    
    
    Set wsA = Sheets("Appointments")    '<<<<<<  Modify sheet name if necessary
    Set wsR = Sheets("Results")         '<<<<<<  Modify sheet name if necessary
    
    Set rAD = wsA.Range("A1")          '<<<<<<  Left top corner of datatable on Appointments sheet
    Set rRS = wsR.Range("A5:V7")           '<<<<<<  Resultstable on Results sheet
    Set rCorr = wsR.Range("Z1")         '<<<<<<  header cell of correction table on Results sheet
    
    'read the data into arrays for fast processing
    vData = rAD.CurrentRegion.Value
    vCorr = rCorr.CurrentRegion.Value
    vRS = rRS.Value
    
    'get the number of rows for the arrays
    UBi1 = UBound(vCorr, 1)
    UBd1 = UBound(vData, 1)
    
    'if correction array only one column then edits entered
    If UBound(vCorr, 2) = 1 Then
        MsgBox "No corrections entered."
        Exit Sub
    End If

    
    ReDim vOut(1 To 1, 1 To 8)
    
    'put results table in array, in same order as appointment table . Data in column F (6) and V (22)
    vOut(1, 3) = vRS(1, 6)
    vOut(1, 4) = vRS(1, 22)
    vOut(1, 5) = vRS(2, 6)
    vOut(1, 6) = vRS(2, 22)
    vOut(1, 7) = vRS(3, 6)
    vOut(1, 8) = vRS(3, 22)
    
    sIDN = wsR.Range("U2")
    
    If Len(sIDN) Then
        'ID nr given on Results sheet
        lC = 1
        
    Else
        'no ID nr on results sheet, look up using other data
        lC = 3
        sIDN = vOut(1, 3)
    End If
    
    
    For lRd = 1 To UBd1
        If sIDN Like CStr(vData(lRd, lC)) Then
            If lC = 3 Then
            'ID not used, but name. Make sure right person
                If (vOut(1, 4) Like vData(lRd, 4)) And _
                   (vOut(1, 4) Like vData(lRd, 4)) And _
                   (vOut(1, 4) Like vData(lRd, 4)) And _
                   (vOut(1, 4) Like vData(lRd, 4)) And _
                   (vOut(1, 4) Like vData(lRd, 4)) And _
                   (vOut(1, 4) Like vData(lRd, 4)) Then
                    'found the correct entry in the appointment table
                        Exit For
                End If
            Else
                Exit For
            End If
        End If
    Next lRd
    
    'error check
    If lRd > UBd1 Then
        MsgBox "Error: ID or Name not found", vbCritical + vbOKOnly, _
            Title:="Problem with the results table"
        Exit Sub
    End If
    
    'Now lRd holds the line in the appointments table to be edited
    
    'go through the correction table and replace the relevant values in the vOut array
    
    For lRi = 3 To UBi1 'skip title & date
        vCh = vCorr(lRi, 2)
        If Len(vCh) Then
            Select Case lRi
                Case 3  'name
                    vOut(1, 3) = vCh
                Case 4  'AMKA
                    vOut(1, 5) = vCh
                Case 5  'Ilikia
                    vOut(1, 4) = vCh
                Case 6  'TEP
                    vOut(1, 6) = vCh
                Case 7  'ILE
                    vOut(1, 8) = vCh
                Case 8  'Branch
                    vOut(1, 7) = vCh
                Case 9  'Doctor
                    vOut(1, 2) = vCh
            End Select
        End If
    Next lRi
    'copy ID nr
    vOut(1, 1) = vData(lRd, 1)
    
    
    'Check if there is a doctor already in the appointmens table for this person
    sIDN = vData(lRd, 2)    'copy name existing doctor into sIDN
    Select Case True
        Case Len(sIDN) And (vOut(1, 2) Like sIDN)
            'both names same, do nothing
        Case Len(sIDN) And Len(vOut(1, 2)) = 0
            'correction entry is empty
            vOut(1, 2) = sIDN       'copy existing doc to out array
        Case Len(sIDN) And Not (vOut(1, 2) Like sIDN)
            'different names , check
            vIBR = MsgBox(Prompt:="A different doctor has been entered." & vbCrLf & _
                                "Current: " & sIDN & "," & vbCrLf & _
                                "New: " & vOut(1, 2) & "." & vbCrLf & vbCrLf & _
                                "Press OK to confirm change, Cancel to keep current doctor", _
                          Buttons:=vbExclamation + vbOKCancel, _
                          Title:="Changed Doctor")
            If vIBR <> vbOK Then
                vOut(1, 2) = sIDN       'copy existing doc to out array
            End If
        Case Else
            'do nothing
    End Select
    
    'Now write the output array across the line in the appointments sheet
    'calculate row on sheet, in case data does not start in A1
    lRo = rAD.Row + lRd - 1
    
    'write the line
    wsA.Cells(lRo, 1).Resize(1, 8).Value = vOut
    
    'clear the correction table
    rCorr.Offset(1, 1).Resize(9, 1).ClearContents
    
End Sub
 
Upvote 0
sijpie said:
VBA Code: 
Option Explicit

Sub Transfer_Corrected_Data()
    Dim vCorr As Variant, vOut As Variant, vData As Variant, vRS As Variant
    Dim lRi As Long, lRo As Long, lRd As Long, UBi1 As Long, UBd1 As Long, lC As Long
    Dim wsA As Worksheet, wsR As Worksheet
    Dim rAD As Range, rRS As Range, rCorr As Range
    Dim sIDN As String, vCh As Variant
    Dim vIBR As VbMsgBoxResult
   
   
   
    Set wsA = Sheets("Appointments")    '<<<<<<  Modify sheet name if necessary
    Set wsR = Sheets("Results")         '<<<<<<  Modify sheet name if necessary
   
    Set rAD = wsA.Range("A1")          '<<<<<<  Left top corner of datatable on Appointments sheet
    Set rRS = wsR.Range("A5:V7")           '<<<<<<  Resultstable on Results sheet
    Set rCorr = wsR.Range("Z1")         '<<<<<<  header cell of correction table on Results sheet
   
    'read the data into arrays for fast processing
    vData = rAD.CurrentRegion.Value
    vCorr = rCorr.CurrentRegion.Value
    vRS = rRS.Value
   
    'get the number of rows for the arrays
    UBi1 = UBound(vCorr, 1)
    UBd1 = UBound(vData, 1)
   
    'if correction array only one column then edits entered
    If UBound(vCorr, 2) = 1 Then
        MsgBox "No corrections entered."
        Exit Sub
    End If

   
    ReDim vOut(1 To 1, 1 To 8)
   
    'put results table in array, in same order as appointment table . Data in column F (6) and V (22)
    vOut(1, 3) = vRS(1, 6)
    vOut(1, 4) = vRS(1, 22)
    vOut(1, 5) = vRS(2, 6)
    vOut(1, 6) = vRS(2, 22)
    vOut(1, 7) = vRS(3, 6)
    vOut(1, 8) = vRS(3, 22)
   
    sIDN = wsR.Range("U2")
   
    If Len(sIDN) Then
        'ID nr given on Results sheet
        lC = 1
       
    Else
        'no ID nr on results sheet, look up using other data
        lC = 3
        sIDN = vOut(1, 3)
    End If
   
   
    For lRd = 1 To UBd1
        If sIDN Like CStr(vData(lRd, lC)) Then
            If lC = 3 Then
            'ID not used, but name. Make sure right person
                If (vOut(1, 4) Like vData(lRd, 4)) And _
                   (vOut(1, 4) Like vData(lRd, 4)) And _
                   (vOut(1, 4) Like vData(lRd, 4)) And _
                   (vOut(1, 4) Like vData(lRd, 4)) And _
                   (vOut(1, 4) Like vData(lRd, 4)) And _
                   (vOut(1, 4) Like vData(lRd, 4)) Then
                    'found the correct entry in the appointment table
                        Exit For
                End If
            Else
                Exit For
            End If
        End If
    Next lRd
   
    'error check
    If lRd > UBd1 Then
        MsgBox "Error: ID or Name not found", vbCritical + vbOKOnly, _
            Title:="Problem with the results table"
        Exit Sub
    End If
   
    'Now lRd holds the line in the appointments table to be edited
   
    'go through the correction table and replace the relevant values in the vOut array
   
    For lRi = 3 To UBi1 'skip title & date
        vCh = vCorr(lRi, 2)
        If Len(vCh) Then
            Select Case lRi
                Case 3  'name
                    vOut(1, 3) = vCh
                Case 4  'AMKA
                    vOut(1, 5) = vCh
                Case 5  'Ilikia
                    vOut(1, 4) = vCh
                Case 6  'TEP
                    vOut(1, 6) = vCh
                Case 7  'ILE
                    vOut(1, 8) = vCh
                Case 8  'Branch
                    vOut(1, 7) = vCh
                Case 9  'Doctor
                    vOut(1, 2) = vCh
            End Select
        End If
    Next lRi
    'copy ID nr
    vOut(1, 1) = vData(lRd, 1)
   
   
    'Check if there is a doctor already in the appointmens table for this person
    sIDN = vData(lRd, 2)    'copy name existing doctor into sIDN
    Select Case True
        Case Len(sIDN) And (vOut(1, 2) Like sIDN)
            'both names same, do nothing
        Case Len(sIDN) And Len(vOut(1, 2)) = 0
            'correction entry is empty
            vOut(1, 2) = sIDN       'copy existing doc to out array
        Case Len(sIDN) And Not (vOut(1, 2) Like sIDN)
            'different names , check
            vIBR = MsgBox(Prompt:="A different doctor has been entered." & vbCrLf & _
                                "Current: " & sIDN & "," & vbCrLf & _
                                "New: " & vOut(1, 2) & "." & vbCrLf & vbCrLf & _
                                "Press OK to confirm change, Cancel to keep current doctor", _
                          Buttons:=vbExclamation + vbOKCancel, _
                          Title:="Changed Doctor")
            If vIBR <> vbOK Then
                vOut(1, 2) = sIDN       'copy existing doc to out array
            End If
        Case Else
            'do nothing
    End Select
   
    'Now write the output array across the line in the appointments sheet
    'calculate row on sheet, in case data does not start in A1
    lRo = rAD.Row + lRd - 1
   
    'write the line
    wsA.Cells(lRo, 1).Resize(1, 8).Value = vOut
   
    'clear the correction table
    rCorr.Offset(1, 1).Resize(9, 1).ClearContents
   
End Sub
Click to expand...
Thanks, I'll try this as soon as I get back to office!
 
Upvote 0
sijpie said:
VBA Code: 
Option Explicit

Sub Transfer_Corrected_Data()
    Dim vCorr As Variant, vOut As Variant, vData As Variant, vRS As Variant
    Dim lRi As Long, lRo As Long, lRd As Long, UBi1 As Long, UBd1 As Long, lC As Long
    Dim wsA As Worksheet, wsR As Worksheet
    Dim rAD As Range, rRS As Range, rCorr As Range
    Dim sIDN As String, vCh As Variant
    Dim vIBR As VbMsgBoxResult
 
 
 
    Set wsA = Sheets("Appointments")    '<<<<<<  Modify sheet name if necessary
    Set wsR = Sheets("Results")         '<<<<<<  Modify sheet name if necessary
 
    Set rAD = wsA.Range("A1")          '<<<<<<  Left top corner of datatable on Appointments sheet
    Set rRS = wsR.Range("A5:V7")           '<<<<<<  Resultstable on Results sheet
    Set rCorr = wsR.Range("Z1")         '<<<<<<  header cell of correction table on Results sheet
 
    'read the data into arrays for fast processing
    vData = rAD.CurrentRegion.Value
    vCorr = rCorr.CurrentRegion.Value
    vRS = rRS.Value
 
    'get the number of rows for the arrays
    UBi1 = UBound(vCorr, 1)
    UBd1 = UBound(vData, 1)
 
    'if correction array only one column then edits entered
    If UBound(vCorr, 2) = 1 Then
        MsgBox "No corrections entered."
        Exit Sub
    End If

 
    ReDim vOut(1 To 1, 1 To 8)
 
    'put results table in array, in same order as appointment table . Data in column F (6) and V (22)
    vOut(1, 3) = vRS(1, 6)
    vOut(1, 4) = vRS(1, 22)
    vOut(1, 5) = vRS(2, 6)
    vOut(1, 6) = vRS(2, 22)
    vOut(1, 7) = vRS(3, 6)
    vOut(1, 8) = vRS(3, 22)
 
    sIDN = wsR.Range("U2")
 
    If Len(sIDN) Then
        'ID nr given on Results sheet
        lC = 1
    
    Else
        'no ID nr on results sheet, look up using other data
        lC = 3
        sIDN = vOut(1, 3)
    End If
 
 
    For lRd = 1 To UBd1
        If sIDN Like CStr(vData(lRd, lC)) Then
            If lC = 3 Then
            'ID not used, but name. Make sure right person
                If (vOut(1, 4) Like vData(lRd, 4)) And _
                   (vOut(1, 4) Like vData(lRd, 4)) And _
                   (vOut(1, 4) Like vData(lRd, 4)) And _
                   (vOut(1, 4) Like vData(lRd, 4)) And _
                   (vOut(1, 4) Like vData(lRd, 4)) And _
                   (vOut(1, 4) Like vData(lRd, 4)) Then
                    'found the correct entry in the appointment table
                        Exit For
                End If
            Else
                Exit For
            End If
        End If
    Next lRd
 
    'error check
    If lRd > UBd1 Then
        MsgBox "Error: ID or Name not found", vbCritical + vbOKOnly, _
            Title:="Problem with the results table"
        Exit Sub
    End If
 
    'Now lRd holds the line in the appointments table to be edited
 
    'go through the correction table and replace the relevant values in the vOut array
 
    For lRi = 3 To UBi1 'skip title & date
        vCh = vCorr(lRi, 2)
        If Len(vCh) Then
            Select Case lRi
                Case 3  'name
                    vOut(1, 3) = vCh
                Case 4  'AMKA
                    vOut(1, 5) = vCh
                Case 5  'Ilikia
                    vOut(1, 4) = vCh
                Case 6  'TEP
                    vOut(1, 6) = vCh
                Case 7  'ILE
                    vOut(1, 8) = vCh
                Case 8  'Branch
                    vOut(1, 7) = vCh
                Case 9  'Doctor
                    vOut(1, 2) = vCh
            End Select
        End If
    Next lRi
    'copy ID nr
    vOut(1, 1) = vData(lRd, 1)
 
 
    'Check if there is a doctor already in the appointmens table for this person
    sIDN = vData(lRd, 2)    'copy name existing doctor into sIDN
    Select Case True
        Case Len(sIDN) And (vOut(1, 2) Like sIDN)
            'both names same, do nothing
        Case Len(sIDN) And Len(vOut(1, 2)) = 0
            'correction entry is empty
            vOut(1, 2) = sIDN       'copy existing doc to out array
        Case Len(sIDN) And Not (vOut(1, 2) Like sIDN)
            'different names , check
            vIBR = MsgBox(Prompt:="A different doctor has been entered." & vbCrLf & _
                                "Current: " & sIDN & "," & vbCrLf & _
                                "New: " & vOut(1, 2) & "." & vbCrLf & vbCrLf & _
                                "Press OK to confirm change, Cancel to keep current doctor", _
                          Buttons:=vbExclamation + vbOKCancel, _
                          Title:="Changed Doctor")
            If vIBR <> vbOK Then
                vOut(1, 2) = sIDN       'copy existing doc to out array
            End If
        Case Else
            'do nothing
    End Select
 
    'Now write the output array across the line in the appointments sheet
    'calculate row on sheet, in case data does not start in A1
    lRo = rAD.Row + lRd - 1
 
    'write the line
    wsA.Cells(lRo, 1).Resize(1, 8).Value = vOut
 
    'clear the correction table
    rCorr.Offset(1, 1).Resize(9, 1).ClearContents
 
End Sub
Click to expand...

I am afraid that either I am not using it correctly or I did not give you all the necessary info. This macro doesn't seem to be doing anything.

Set rAD = wsA.Range("A1") '<<<<<< Left top corner of datatable on Appointments sheet
Click to expand...
This is A5 (first row of data) or A4 (table heading)

Set rRS = wsR.Range("A5:V7") '<<<<<< Resultstable on Results sheet
Click to expand...
We just use 6 cells within this range, that have formulas in them. Not sure if we really need this line. I don't need any data to be copied in those cells.

Case Len(sIDN) And (vOut(1, 2) Like sIDN)
'both names same, do nothing
Click to expand...
I'd rather to have a pop up message even if names are the same.

I think it will be easier for you if I upload the excel file, because the add on that copies it makes my computer crash!

Google drive link to file

P.S. Please remember to include the macro assigned to "Save as PDF" in your macro.

Thanks!
 
Last edited:
Upvote 0
Ok. I'm quite busy at the moment, I'll see if I can do something coming week
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question Question
Macro to correct entries across multiple sheets
Replies
1
Views
108
Lux Aeterna
L
Sufiyan97
  • Solved
VBA Filter Names from List One by One and then Copy filtered data v2
Replies
6
Views
175
Sufiyan97
Sufiyan97
M
  • Question Question
How to filter/lookup rows of data based on the latest date in a cell
Replies
8
Views
2K
Peter_SSs
Peter_SSs
B
  • Question Question
countifs and remove data completed
2
Replies
10
Views
878
MuchToLearn
M
staticfluids
  • Question Question
Distribute Number into Several Part (Increment) Based on Other Data (Dynamic Array)
Replies
2
Views
373
staticfluids
staticfluids

Forum statistics

Threads
1,223,236
Messages
6,170,917
Members
452,366
Latest member
TePunaBloke

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