Macro help

kshipp91 · May 12, 2021

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!

Fluff · May 12, 2021

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 · May 13, 2021

Fluff said:

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

Fluff · May 13, 2021

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

kshipp91 · May 13, 2021

Fluff said:

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 · May 13, 2021

Shouldn't need to have to run it twice.
If I start with

+Fluff 1.xlsm

A

B

C

1

2

005591

04/05/2021

1

3

005592

05/05/2021

2

4

005593

06/05/2021

3

5

005594

07/05/2021

4

6

005595

08/05/2021

5

7

005596

09/05/2021

6

8

005597

10/05/2021

7

9

015598

11/05/2021

8

10

005599

12/05/2021

9

11

005600

13/05/2021

10

12

005601

14/05/2021

11

13

005602

15/05/2021

12

14

005603

16/05/2021

13

15

005604

17/05/2021

14

16

005605

18/05/2021

15

17

005606

19/05/2021

16

Data

And the Record sheet is blank I get

+Fluff 1.xlsm

A

B

C

D

1

2

005591

05/04/2021

1

13/05/2021 15:01:47

3

005592

05/05/2021

2

13/05/2021 15:01:47

4

005593

05/06/2021

3

13/05/2021 15:01:47

5

005594

05/07/2021

4

13/05/2021 15:01:47

6

005595

05/08/2021

5

13/05/2021 15:01:47

7

005596

05/09/2021

6

13/05/2021 15:01:47

8

005597

05/10/2021

7

13/05/2021 15:01:47

9

015598

05/11/2021

8

13/05/2021 15:01:47

10

005599

05/12/2021

9

13/05/2021 15:01:47

11

005600

13/05/2021

10

13/05/2021 15:01:47

12

005601

14/05/2021

11

13/05/2021 15:01:47

13

005602

15/05/2021

12

13/05/2021 15:01:47

14

005603

16/05/2021

13

13/05/2021 15:01:47

15

005604

17/05/2021

14

13/05/2021 15:01:47

16

005605

18/05/2021

15

13/05/2021 15:01:47

17

005606

19/05/2021

16

13/05/2021 15:01:47

Record

kshipp91 · May 13, 2021

Fluff said:
Shouldn't need to have to run it twice.
If I start with

+Fluff 1.xlsm
A B C
1
2 005591 04/05/2021 1
3 005592 05/05/2021 2
4 005593 06/05/2021 3
5 005594 07/05/2021 4
6 005595 08/05/2021 5
7 005596 09/05/2021 6
8 005597 10/05/2021 7
9 015598 11/05/2021 8
10 005599 12/05/2021 9
11 005600 13/05/2021 10
12 005601 14/05/2021 11
13 005602 15/05/2021 12
14 005603 16/05/2021 13
15 005604 17/05/2021 14
16 005605 18/05/2021 15
17 005606 19/05/2021 16
Data

And the Record sheet is blank I get

+Fluff 1.xlsm
A B C D
1
2 005591 05/04/2021 1 13/05/2021 15:01:47
3 005592 05/05/2021 2 13/05/2021 15:01:47
4 005593 05/06/2021 3 13/05/2021 15:01:47
5 005594 05/07/2021 4 13/05/2021 15:01:47
6 005595 05/08/2021 5 13/05/2021 15:01:47
7 005596 05/09/2021 6 13/05/2021 15:01:47
8 005597 05/10/2021 7 13/05/2021 15:01:47
9 015598 05/11/2021 8 13/05/2021 15:01:47
10 005599 05/12/2021 9 13/05/2021 15:01:47
11 005600 13/05/2021 10 13/05/2021 15:01:47
12 005601 14/05/2021 11 13/05/2021 15:01:47
13 005602 15/05/2021 12 13/05/2021 15:01:47
14 005603 16/05/2021 13 13/05/2021 15:01:47
15 005604 17/05/2021 14 13/05/2021 15:01:47
16 005605 18/05/2021 15 13/05/2021 15:01:47
17 005606 19/05/2021 16 13/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 · May 13, 2021

You're welcome & thanks for the feedback.

Macro help

kshipp91

New Member

Attachments

Excel Facts

Fluff

MrExcel MVP, Moderator

kshipp91

New Member

Fluff

MrExcel MVP, Moderator

kshipp91

New Member

Fluff

MrExcel MVP, Moderator

kshipp91

New Member

Fluff

MrExcel MVP, Moderator

Similar threads

Forum statistics

Share this page

Macro help

New Member

Attachments

Excel Facts

MrExcel MVP, Moderator

New Member

MrExcel MVP, Moderator

New Member

MrExcel MVP, Moderator

New Member

MrExcel MVP, Moderator

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock