Macro help

kshipp91

New Member
Joined
May 12, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Hello everyone,

I am looking for some help as I am relatively new to VBA and macros.

I have an Excel sheet that has a list of quote numbers in column A (eg 005624) on sheet “Data”. I also have in the same workbook a sheet “Record” (column A = quote number and column B = date) that I need to keep a record of when a quote number is removed. What I need is a macro that looks at column A in Data and see if the quote number appears in Record. If it does appear update the date to today, if it does not appear add it to Record and input todays date. The logic being that for every day that the macro runs, the date would be updated until the quote number no longer appears in Data thereby leaving the last date that it did. I hope this makes sense to someone 😊

Thank you in advance!
 

Attachments

  • Screenshot.png
    Screenshot.png
    31.5 KB · Views: 6

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
59,887
Office Version
  1. 365
Platform
  1. Windows
Hi & welcome to MrExcel.
How about
VBA Code:
Sub kshipp()
   Dim Cl As Range
   Dim Dic As Object
  
   Set Dic = CreateObject("scripting.dictionary")
   With Sheets("Data")
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         Dic(Cl.Text) = Cl.Offset(, 1).Value
      Next Cl
   End With
   With Sheets("Record")
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         If Dic.Exists(Cl.Text) Then
            Cl.Offset(, 1).Value = Dic(Cl.Text)
            Dic.Remove Cl.Text
         End If
      Next Cl
      If Dic.Count > 0 Then
         With .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(Dic.Count, 2)
            .Resize( ,1).NumberFormat = "@"
            .Value = Application.Transpose(Array(Dic.Keys, Dic.Items))
         End With
      End If
   End With
End Sub
 

kshipp91

New Member
Joined
May 12, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Hi & welcome to MrExcel.
How about
VBA Code:
Sub kshipp()
   Dim Cl As Range
   Dim Dic As Object
 
   Set Dic = CreateObject("scripting.dictionary")
   With Sheets("Data")
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         Dic(Cl.Text) = Cl.Offset(, 1).Value
      Next Cl
   End With
   With Sheets("Record")
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         If Dic.Exists(Cl.Text) Then
            Cl.Offset(, 1).Value = Dic(Cl.Text)
            Dic.Remove Cl.Text
         End If
      Next Cl
      If Dic.Count > 0 Then
         With .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(Dic.Count, 2)
            .Resize( ,1).NumberFormat = "@"
            .Value = Application.Transpose(Array(Dic.Keys, Dic.Items))
         End With
      End If
   End With
End Sub
Hi Fluff,

Thank you for the welcome :) Amazing! Thank you so so much, the code you sent me worked so well and allowed me to make huge headway for my final working sheet!

I needed to pull through to my "records" tab a couple more columns, I implemented your code and made a couple tweaks (badly) to get the other columns pulled through, but now if the quote is not in the list on the "Records" tab then it adds the line, but only the Quote number and Date raised. The other columns do not pull through until I run it again. I hope that makes sense. Would you mind taking a look and maybe advise where I am going wrong? I know that I could write my edits better, it's clunky so any insight you could give I would really appreciate! Thank you

VBA Code:
Private Sub Workbook_Open()
ActiveWorkbook.RefreshAll



Dim Cl As Range
   Dim Dic As Object
   Dim Dic2 As Object
   Dim Dic3 As Object
   Dim Dic4 As Object
    
   Set Dic = CreateObject("scripting.dictionary")
   Set Dic2 = CreateObject("scripting.dictionary")
   Set Dic3 = CreateObject("scripting.dictionary")
   Set Dic4 = CreateObject("scripting.dictionary")
   With Sheets("Data")
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         Dic(Cl.Text) = Cl.Offset(, 1).Value
          Dic2(Cl.Text) = Cl.Offset(, 2).Value
           Dic3(Cl.Text) = Now()
           
      Next Cl
   End With
   With Sheets("Record")
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         If Dic.Exists(Cl.Text) Then
            Cl.Offset(, 1).Value = Dic(Cl.Text)
            Dic.Remove Cl.Text
         End If
      Next Cl
     
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         If Dic2.Exists(Cl.Text) Then
            Cl.Offset(, 2).Value = Dic2(Cl.Text)
            Dic2.Remove Cl.Text
         End If
      Next Cl
     
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         If Dic3.Exists(Cl.Text) Then
            Cl.Offset(, 3).Value = Dic3(Cl.Text)
            Dic3.Remove Cl.Text
         End If
      Next Cl
     
             
     
     
      If Dic.Count > 0 Then
        With .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(Dic.Count, 2)
           .Resize(, 1).NumberFormat = "@"
           .Value = Application.Transpose(Array(Dic.Keys, Dic.Items))
       End With
     End If
          
          
     
   End With
End Sub
 
Last edited by a moderator:

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
59,887
Office Version
  1. 365
Platform
  1. Windows
Try it like
VBA Code:
   Dim Cl As Range
   Dim Dic As Object
    
   Set Dic = CreateObject("scripting.dictionary")
   With Sheets("Data")
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         Dic(Cl.Text) = Array(Cl.Offset(, 1).Value, Cl.Offset(, 2).Value, Now)
      Next Cl
   End With
   With Sheets("Record")
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         If Dic.Exists(Cl.Text) Then
            Cl.Offset(, 1).Resize(, 3).Value = Dic(Cl.Text)
            Dic.Remove Cl.Text
         End If
      Next Cl
      
      If Dic.Count > 0 Then
         With .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(Dic.Count)
            .Resize(, 1).NumberFormat = "@"
            .Value = Application.Transpose(Dic.Keys)
            .Offset(, 1).Resize(, 3) = Application.Index(Dic.Items, 0)
         End With
      End If
   End With
 
Solution

kshipp91

New Member
Joined
May 12, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Try it like
VBA Code:
   Dim Cl As Range
   Dim Dic As Object
   
   Set Dic = CreateObject("scripting.dictionary")
   With Sheets("Data")
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         Dic(Cl.Text) = Array(Cl.Offset(, 1).Value, Cl.Offset(, 2).Value, Now)
      Next Cl
   End With
   With Sheets("Record")
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         If Dic.Exists(Cl.Text) Then
            Cl.Offset(, 1).Resize(, 3).Value = Dic(Cl.Text)
            Dic.Remove Cl.Text
         End If
      Next Cl
     
      If Dic.Count > 0 Then
         With .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(Dic.Count)
            .Resize(, 1).NumberFormat = "@"
            .Value = Application.Transpose(Dic.Keys)
            .Offset(, 1).Resize(, 3) = Application.Index(Dic.Items, 0)
         End With
      End If
   End With
Thank you, that's great! Much clearer. I still have to run the macro twice for the next two fields to populate. Sorry, is there something I am missing?
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
59,887
Office Version
  1. 365
Platform
  1. Windows
Shouldn't need to have to run it twice.
If I start with
+Fluff 1.xlsm
ABC
1
200559104/05/20211
300559205/05/20212
400559306/05/20213
500559407/05/20214
600559508/05/20215
700559609/05/20216
800559710/05/20217
901559811/05/20218
1000559912/05/20219
1100560013/05/202110
1200560114/05/202111
1300560215/05/202112
1400560316/05/202113
1500560417/05/202114
1600560518/05/202115
1700560619/05/202116
Data


And the Record sheet is blank I get
+Fluff 1.xlsm
ABCD
1
200559105/04/2021113/05/2021 15:01:47
300559205/05/2021213/05/2021 15:01:47
400559305/06/2021313/05/2021 15:01:47
500559405/07/2021413/05/2021 15:01:47
600559505/08/2021513/05/2021 15:01:47
700559605/09/2021613/05/2021 15:01:47
800559705/10/2021713/05/2021 15:01:47
901559805/11/2021813/05/2021 15:01:47
1000559905/12/2021913/05/2021 15:01:47
1100560013/05/20211013/05/2021 15:01:47
1200560114/05/20211113/05/2021 15:01:47
1300560215/05/20211213/05/2021 15:01:47
1400560316/05/20211313/05/2021 15:01:47
1500560417/05/20211413/05/2021 15:01:47
1600560518/05/20211513/05/2021 15:01:47
1700560619/05/20211613/05/2021 15:01:47
Record
 

kshipp91

New Member
Joined
May 12, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Shouldn't need to have to run it twice.
If I start with
+Fluff 1.xlsm
ABC
1
200559104/05/20211
300559205/05/20212
400559306/05/20213
500559407/05/20214
600559508/05/20215
700559609/05/20216
800559710/05/20217
901559811/05/20218
1000559912/05/20219
1100560013/05/202110
1200560114/05/202111
1300560215/05/202112
1400560316/05/202113
1500560417/05/202114
1600560518/05/202115
1700560619/05/202116
Data


And the Record sheet is blank I get
+Fluff 1.xlsm
ABCD
1
200559105/04/2021113/05/2021 15:01:47
300559205/05/2021213/05/2021 15:01:47
400559305/06/2021313/05/2021 15:01:47
500559405/07/2021413/05/2021 15:01:47
600559505/08/2021513/05/2021 15:01:47
700559605/09/2021613/05/2021 15:01:47
800559705/10/2021713/05/2021 15:01:47
901559805/11/2021813/05/2021 15:01:47
1000559905/12/2021913/05/2021 15:01:47
1100560013/05/20211013/05/2021 15:01:47
1200560114/05/20211113/05/2021 15:01:47
1300560215/05/20211213/05/2021 15:01:47
1400560316/05/20211313/05/2021 15:01:47
1500560417/05/20211413/05/2021 15:01:47
1600560518/05/20211513/05/2021 15:01:47
1700560619/05/20211613/05/2021 15:01:47
Record
Not sure what I did there, but it works perfectly now I tried again. Thank you for your help and your patience! :)
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
59,887
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
 

Forum statistics

Threads
1,136,275
Messages
5,674,786
Members
419,524
Latest member
helensesc

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
Top