Excel 365 Compare Date & Copy Cell Data for Data Base

B

bz61

New Member
Joined
Feb 1, 2024
Messages
20
Office Version
  1. 365
Platform
  1. Windows
Hello, I'm not a proficient at Excel VBA programming & in need of assistance with the following issue: I have an excel workbook with multiple sheets for planning and building a data base. Attached is one of the sheets that extracts data from one of the other sheets. The upper left range of cells tracks the data live, so I'm unable to use an excel program to transfer the data to the right-side columns and save it. I've attached a VBA program that I found on this site and attempted to modify without much success. It will only copy 3 of the cells after that I get errors if I try to add more lines of code. I need to have the data on the left side under the "AW ENG COUNT" column to be transferred over to the corresponding columns and date on the right side. I'm using the "Today ()" function on the left side "Date" column and Excel auto populate date function on the right-side column. I will be putting the code into the Private Sub Workbook_Open & Close, so when Planners open or close this Workbook, the data will be updated to the last entry for that day and be repeated daily. Thank you in advance.

Private Sub Workbook_Close()

VBA Code: 
Dim Cl As range
    Dim Dic As Object
    
    Set Dic = CreateObject("scripting.dictionary")
    With Sheets("Graph Data")
        For Each Cl In .range("d5", .range("d" & Rows.Count).End(xlUp))
            Dic(Cl.Value) = Cl.Offset(1, -1).Value
        Next Cl
    End With
    With Sheets("Graph Data")
        For Each Cl In .range("ba5", .range("ba" & Rows.Count).End(xlUp))
            If Dic.exists(Cl.Value) Then Cl.Offset(, -4).Value = Dic(Cl.Value)
        Next Cl
    End With
    
End Sub
 

Attachments

  • Date Compare Program.jpg
    Date Compare Program.jpg
    70.3 KB · Views: 8
  • Data Base.jpg
    Data Base.jpg
    135.3 KB · Views: 9
Sort by date Sort by votes

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
Put the below on your worksheet code.

If will handle either updating or inserting based on the current date.
It will overwrite if someone changes cells "C5:C9"


Book1
BCDAYAZBABBBCBD
3
4TitleAW ENGDateAW ENG Scope ReviewAW Eng mat reviewMAT InitMat DUEMat OverDue
5AW ENG Scope ReviewTRUE2/1/2024TRUEFALSEdasfasd2/3/2024FALSE
6AW Eng mat reviewTRUE2/3/2024TRUETRUEasdfa2/1/2024TRUE
7MAT Initasdfa
8Mat DUE2/1/2024
9Mat OverDueTRUE
10
Sheet1


VBA Code: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    
    If Not Intersect(Target, Me.Range("C5:C9")) Is Nothing Then
        RangeInsertOrUpdateBasedOnToday
        Exit Sub
    End If
End Sub


Private Sub RangeInsertOrUpdateBasedOnToday()
    
    Dim tbl As ListObject
    Dim ws As Worksheet
    Dim ar As Variant
    Dim dT As Date
    Dim rng As Range
    Dim theRow As ListRow

    dT = Date
    Set ws = ThisWorkbook.Sheets("Sheet1") '  your sheet name
    Set tbl = ws.ListObjects("tblTrack")  ' your table name

    ' get the values to update or insert
    ar = Range("C5:C9").Value
    
    If tbl.DataBodyRange Is Nothing Then GoTo insert
    Set rng = tbl.ListColumns("Date").DataBodyRange.Find(What:=dT, LookIn:=xlValues, LookAt:=xlWhole)
    If rng Is Nothing Then GoTo insert
    
    ' update
    rng.Value = dT
    Set rng = rng.Offset(, 1).Resize(, 5)
    rng.Value = Application.Transpose(ar)
    
    GoTo out
       
update:
        Debug.Print "update"
    GoTo out
    
insert:
    Set theRow = tbl.ListRows.Add ' add at bottom of table
    theRow.Range.Cells(, 1).Value = dT
    Set rng = theRow.Range.Cells(, 2)
    Set rng = rng.Resize(, 5)
    rng.Value = Application.Transpose(ar)

out:
    Set theRow = Nothing
    Set tbl = Nothing
    Set ws = Nothing
End Sub
 
Upvote 0
skillilea said:
Put the below on your worksheet code.

If will handle either updating or inserting based on the current date.
It will overwrite if someone changes cells "C5:C9"


Book1
BCDAYAZBABBBCBD
3
4TitleAW ENGDateAW ENG Scope ReviewAW Eng mat reviewMAT InitMat DUEMat OverDue
5AW ENG Scope ReviewTRUE2/1/2024TRUEFALSEdasfasd2/3/2024FALSE
6AW Eng mat reviewTRUE2/3/2024TRUETRUEasdfa2/1/2024TRUE
7MAT Initasdfa
8Mat DUE2/1/2024
9Mat OverDueTRUE
10
Sheet1


VBA Code: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
   
    If Not Intersect(Target, Me.Range("C5:C9")) Is Nothing Then
        RangeInsertOrUpdateBasedOnToday
        Exit Sub
    End If
End Sub


Private Sub RangeInsertOrUpdateBasedOnToday()
   
    Dim tbl As ListObject
    Dim ws As Worksheet
    Dim ar As Variant
    Dim dT As Date
    Dim rng As Range
    Dim theRow As ListRow

    dT = Date
    Set ws = ThisWorkbook.Sheets("Sheet1") '  your sheet name
    Set tbl = ws.ListObjects("tblTrack")  ' your table name

    ' get the values to update or insert
    ar = Range("C5:C9").Value
   
    If tbl.DataBodyRange Is Nothing Then GoTo insert
    Set rng = tbl.ListColumns("Date").DataBodyRange.Find(What:=dT, LookIn:=xlValues, LookAt:=xlWhole)
    If rng Is Nothing Then GoTo insert
   
    ' update
    rng.Value = dT
    Set rng = rng.Offset(, 1).Resize(, 5)
    rng.Value = Application.Transpose(ar)
   
    GoTo out
      
update:
        Debug.Print "update"
    GoTo out
   
insert:
    Set theRow = tbl.ListRows.Add ' add at bottom of table
    theRow.Range.Cells(, 1).Value = dT
    Set rng = theRow.Range.Cells(, 2)
    Set rng = rng.Resize(, 5)
    rng.Value = Application.Transpose(ar)

out:
    Set theRow = Nothing
    Set tbl = Nothing
    Set ws = Nothing
End Sub
Click to expand...
I'm currently not at work, but tomorrow first thing when I'm back at the office I will install the program to see how it works. I'll let you know ASAP. Thank you.
 
Upvote 0
skillilea said:
Put the below on your worksheet code.

If will handle either updating or inserting based on the current date.
It will overwrite if someone changes cells "C5:C9"


Book1
BCDAYAZBABBBCBD
3
4TitleAW ENGDateAW ENG Scope ReviewAW Eng mat reviewMAT InitMat DUEMat OverDue
5AW ENG Scope ReviewTRUE2/1/2024TRUEFALSEdasfasd2/3/2024FALSE
6AW Eng mat reviewTRUE2/3/2024TRUETRUEasdfa2/1/2024TRUE
7MAT Initasdfa
8Mat DUE2/1/2024
9Mat OverDueTRUE
10
Sheet1


VBA Code: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
  
    If Not Intersect(Target, Me.Range("C5:C9")) Is Nothing Then
        RangeInsertOrUpdateBasedOnToday
        Exit Sub
    End If
End Sub


Private Sub RangeInsertOrUpdateBasedOnToday()
  
    Dim tbl As ListObject
    Dim ws As Worksheet
    Dim ar As Variant
    Dim dT As Date
    Dim rng As Range
    Dim theRow As ListRow

    dT = Date
    Set ws = ThisWorkbook.Sheets("Sheet1") '  your sheet name
    Set tbl = ws.ListObjects("tblTrack")  ' your table name

    ' get the values to update or insert
    ar = Range("C5:C9").Value
  
    If tbl.DataBodyRange Is Nothing Then GoTo insert
    Set rng = tbl.ListColumns("Date").DataBodyRange.Find(What:=dT, LookIn:=xlValues, LookAt:=xlWhole)
    If rng Is Nothing Then GoTo insert
  
    ' update
    rng.Value = dT
    Set rng = rng.Offset(, 1).Resize(, 5)
    rng.Value = Application.Transpose(ar)
  
    GoTo out
     
update:
        Debug.Print "update"
    GoTo out
  
insert:
    Set theRow = tbl.ListRows.Add ' add at bottom of table
    theRow.Range.Cells(, 1).Value = dT
    Set rng = theRow.Range.Cells(, 2)
    Set rng = rng.Resize(, 5)
    rng.Value = Application.Transpose(ar)

out:
    Set theRow = Nothing
    Set tbl = Nothing
    Set ws = Nothing
End Sub
Click to expand...
Good morning, I would like to thank you for working your magic with the coding. It works beautifully and I would have never been able to resolve this issue without you. Is there anything I can do for you?
 
Upvote 0
skillilea said:
No worries. Happy To Help and welcome to the Board :)
Click to expand...
Sorry to bother you...I seem to be like that bad penny that keeps turning up : ) When I was testing it this morning I only imputed values from the "Graph Data" worksheet in the right hand columns manual. Today when my Planners started updating on the "Planning" sheet they noticed that the data base wasn't being updating even though the values in the right hand column changed on the "Graph Data" sheet after entering their data on the "Planning" sheet. Is there a fix for this? Every thing else is working perfect. Thank you.
 
Upvote 0
At the top left hand section of the sheet under the toolbar, are macros enabled?

If they don't enable this the macro won't run.
 
Upvote 0
skillilea said:
At the top left hand section of the sheet under the toolbar, are macros enabled?

If they don't enable this the macro won't run.
Click to expand...
They are set to enable.
 

Attachments

  • Macro Settings.jpg
    Macro Settings.jpg
    197.2 KB · Views: 2
Upvote 0
bz61 said:
They are set to enable.
Click to expand...
The program runs when ever the Graph Sheet is updated manually, but it doesn't see a value change when the Planning sheet creates the change on the
Data sheet.
 
Upvote 0
show me the two sheets and the code behind. I didn't know there were 2 sheets. Thought it was all on one based on the picture above.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
Copy hyperlinks from one table column to another. The columns are identical
Replies
2
Views
61
sspatriots
S
S
  • Question
Copy/paste special values of Excel table based on cell value
Replies
2
Views
157
stacey_t
S
B
  • Solved
Object variable or with block variable not set
Replies
2
Views
543
Bagsy
B
N
  • Question
Copy value of Cell to the right - thought I had it
2
Replies
10
Views
674
netrixuser
N
B
  • Solved
scripting.dictionary
Replies
7
Views
531
Fluff
Fluff

Forum statistics

Threads
1,215,071
Messages
6,122,964
Members
449,094
Latest member
Anshu121

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