Excel 365 Compare Date & Copy Cell Data for Data Base

[bz61]

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()

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

 

[skillilea]

Ok, give me a bit I have an idea for you

 

[skillilea]

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
	B	C	D																																															AY	AZ	BA	BB	BC	BD
3
4	Title	AW ENG																																																Date	AW ENG Scope Review	AW Eng mat review	MAT Init	Mat DUE	Mat OverDue
5	AW ENG Scope Review	TRUE																																																2/1/2024	TRUE	FALSE	dasfasd	2/3/2024	FALSE
6	AW Eng mat review	TRUE																																																2/3/2024	TRUE	TRUE	asdfa	2/1/2024	TRUE
7	MAT Init	asdfa
8	Mat DUE	2/1/2024
9	Mat OverDue	TRUE
10
Sheet1

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

 

[bz61]

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
	B	C	D																																															AY	AZ	BA	BB	BC	BD
3
4	Title	AW ENG																																																Date	AW ENG Scope Review	AW Eng mat review	MAT Init	Mat DUE	Mat OverDue
5	AW ENG Scope Review	TRUE																																																2/1/2024	TRUE	FALSE	dasfasd	2/3/2024	FALSE
6	AW Eng mat review	TRUE																																																2/3/2024	TRUE	TRUE	asdfa	2/1/2024	TRUE
7	MAT Init	asdfa
8	Mat DUE	2/1/2024
9	Mat OverDue	TRUE
10
Sheet1

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

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.

 

[bz61]

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
	B	C	D																																															AY	AZ	BA	BB	BC	BD
3
4	Title	AW ENG																																																Date	AW ENG Scope Review	AW Eng mat review	MAT Init	Mat DUE	Mat OverDue
5	AW ENG Scope Review	TRUE																																																2/1/2024	TRUE	FALSE	dasfasd	2/3/2024	FALSE
6	AW Eng mat review	TRUE																																																2/3/2024	TRUE	TRUE	asdfa	2/1/2024	TRUE
7	MAT Init	asdfa
8	Mat DUE	2/1/2024
9	Mat OverDue	TRUE
10
Sheet1

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

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?

 

[skillilea]

No worries. Happy To Help and welcome to the Board

 

[bz61]

No worries. Happy To Help and welcome to the Board

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.

 

[skillilea]

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.

 

[bz61]

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.

They are set to enable.

 

[bz61]

They are set to enable.

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.

 

[skillilea]

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.