macro deleting formulas

[ASadStudent]

This is what the original macro does:
My macro copies data from 1 excel document sheet to another. The document where the data is coming from is called “report” and the document where the data needs to go to is called “maandafsluiting”. The sheet in report is called Page1 and the sheet in maandafsluiting isn't really called in the code.

The data is copied based on the product code that is in the A Column of both documents. If the product codes on both files match then it needs to copy the amount that is in the R column in the “report” document to the F Column in the “Maandverband” document.

What I want to change:
Right now code deletes the =som formulas when it copies the different amounts. I want to find a way so it doesn't do that anymore.
I have asked this question before and made it work for some time, but because of the other changes in the code I did after that it stopped working.

I would greatly appreciate it if you can help me with this problem.


VBA Code:

 Sub Kijken_2()
  Dim Report As Worksheet, Maandafsluiting As Worksheet
  Dim data As Variant, ky As Variant
  Dim lr As Long, rw As Long
  Dim d As Object, d2 As Object
  Dim rng As Range
 
  Set d = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
 
  Set Report = Workbooks.Item("Report").Sheets("Page1")
  Set Maandafsluiting = Workbooks.Item("Maandafsluiting").Sheets(1)
 
  lr = Report.Cells(Rows.Count, 1).End(3).Row
  With Report.Cells(1, 1).Resize(lr, 18)
    data = .Value
    .Interior.ColorIndex = xlNone
  End With
 
  For rw = LBound(data) To UBound(data)
    If data(rw, 18) <> 0 Then
      ky = data(rw, 1)
      If Not d.exists(ky) Then
        d(ky) = data(rw, 18) & "|" & rw
      End If
    End If
  Next rw
 
  lr = Maandafsluiting.Cells(Rows.Count, 1).End(3).Row
  data = Maandafsluiting.Cells(1, 1).Resize(lr, 6).Formula
 
  For rw = LBound(data) To UBound(data)
    ky = data(rw, 1)
    d2(ky) = Empty
    If d.exists(ky) Then
      data(rw, 6) = Split(d(ky), "|")(0)
    End If
  Next rw

  For Each ky In d.keys
    If Not d2.exists(ky) Then
      rw = Split(d(ky), "|")(1)
      If rng Is Nothing Then
        Set rng = Report.Cells(rw, 1)
      Else
        Set rng = Union(rng, Report.Cells(rw, 1))
      End If
    End If
  Next
 
  If Not rng Is Nothing Then rng.Interior.Color = vbRed
 
 
  Maandafsluiting.Cells(1, 6).Resize(UBound(data)).Formula = Application.Index(data, 0, 6)
End Sub

Excel files:

Report.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
1																		Total
2	Product code																	Amount of times sold
3	25006																	15
4	21002																	16
5	25014																	17
6	25012																	1
7	25017																	4
8	25022																	7
9	26015																	43
10	26008																	2
11	26004																	563
12
13
14	23116																	44
15	23117																	23
16	23101																	3
17	23106																	657
18	23112																	89
19	23111																	7
20	23130																	2
21
22
23	24006																	45
24	24001																	2
25	24004																	462
26	23507																	6
27	23508																	46
28	23501																	427
29	23504																	27
30	23132																	246
Page1

Maandafsluiting.xlsx
	A	B	C	D	E	F
1						Total
2	Product codes					Aantal
3	21001
4	21002					16
5	21003
6	21004
7	21005
8	21006
9						Total
10	22000
11	22002
12	22004
13	22006
14	22007
15	22010
16	22012
17	22014
18	22017
19	22018
20	22022
21	22023
22	22031
23	22032
24						Total
25	23101					3
26	23102
27	23103
28	23104
29	23106					657
30	23107
31	23108
32	23109
33	23111					7
34	23112					89
35	23116					44
36	23117					23
37	23121
38						Total
39	23501					427
40	23502
41	23503
42	23504					27
43	23505
44	23506
45	23507					6
46	23508					46
47	23511
48						Total
49	24001					2
50	24003
51	24004					462
52						Total
53	25006					15
54	25008
55	25012					1
56	25013
57	25014					17
58	25016
59	25017					4
60	25022					7
61	25060
62	25061
63	25062
64	25063
65	25064
66						Total
67	26002
68	26004					563
69	26008					2
70	26010
71	26012
72	26014
73	26015					43
74	26018
75						Total
76	23130					2
77	23131
78	23132					246
79	23133
80	24006					45
81	24006					45
82						338
Blad1

Cell Formulas
Range	Formula
F82	F82	=SUM(F76:F81)

 

[ASadStudent]

Or another solution I can think of is making it so that the macro ignores empty spaces.
Does anyone know a way to implement that ?

 

[shinigamilight]

Sub testing()
        Dim wk1, wk2 As Worksheet
        Dim lr, lr2 As Long
        Set wk1 = Workbooks("Book1").Sheets("Sheet1") ' this is the report workbook
        Set wk2 = Workbooks("Book2").Sheets("Sheet1")  ' this is the Maandafsluiting workbook
        Dim k As Integer
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        lr = wk1.Range("A" & Rows.Count).End(xlUp).Row
        lr2 = wk2.Range("A" & Rows.Count).End(xlUp).Row
       
        For k = 3 To lr
                If Not dic.Exists(wk1.Range("A" & k).Value) And wk1.Range("A" & k) <> "" Then
                    dic(wk1.Range("A" & k).Value) = wk1.Range("R" & k).Value
                End If
        Next k
       
        For k = 3 To lr2
                If dic.Exists(wk2.Range("A" & k).Value) And wk2.Range("A" & k) <> "" Then
                    wk2.Range("F" & k) = dic(wk2.Range("A" & k).Value)
                End If
        Next k
       
        dic.RemoveAll
       
End Sub

 

[ASadStudent]

Sub testing()
        Dim wk1, wk2 As Worksheet
        Dim lr, lr2 As Long
        Set wk1 = Workbooks("Book1").Sheets("Sheet1") ' this is the report workbook
        Set wk2 = Workbooks("Book2").Sheets("Sheet1")  ' this is the Maandafsluiting workbook
        Dim k As Integer
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        lr = wk1.Range("A" & Rows.Count).End(xlUp).Row
        lr2 = wk2.Range("A" & Rows.Count).End(xlUp).Row
      
        For k = 3 To lr
                If Not dic.Exists(wk1.Range("A" & k).Value) And wk1.Range("A" & k) <> "" Then
                    dic(wk1.Range("A" & k).Value) = wk1.Range("R" & k).Value
                End If
        Next k
      
        For k = 3 To lr2
                If dic.Exists(wk2.Range("A" & k).Value) And wk2.Range("A" & k) <> "" Then
                    wk2.Range("F" & k) = dic(wk2.Range("A" & k).Value)
                End If
        Next k
      
        dic.RemoveAll
      
End Sub

Thanks for answering my question.
I do have a question I would like to ask you.
Where in my existing code would I add this part ?
Because I don't fully understand how to add the copying part of my code to the code that you wrote.

 

[shinigamilight]

Thanks for answering my question.
I do have a question I would like to ask you.
Where in my existing code would I add this part ?
Because I don't fully understand how to add the copying part of my code to the code that you wrote.

I rewrote the code because your original code is very bad. I'd have to debug it, also why do you have 2 dictionaries in your code. Just use mine and tell me if it works, then I'll explain to you how it works.

 

[ASadStudent]

I rewrote the code because your original code is very bad. I'd have to debug it, also why do you have 2 dictionaries in your code. Just use mine and tell me if it works, then I'll explain to you how it works.

Right now it doesn't work. It doesn't give me a error notice so I don't know why it doesn't work.
Here is what I used:

Sub testing()
        Dim wk1, wk2 As Worksheet
        Dim lr, lr2 As Long
        Set wk1 = Workbooks("Report").Sheets("Page1")
        Set wk2 = Workbooks("Maandafsluiting").Sheets("Blad1")
        Dim k As Integer
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        lr = wk1.Range("A" & Rows.Count).End(xlUp).Row
        lr2 = wk2.Range("A" & Rows.Count).End(xlUp).Row
      
        For k = 3 To lr
                If Not dic.Exists(wk1.Range("A" & k).Value) And wk1.Range("A" & k) <> "" Then
                    dic(wk1.Range("A" & k).Value) = wk1.Range("R" & k).Value
                End If
        Next k
      
        For k = 3 To lr2
                If dic.Exists(wk2.Range("A" & k).Value) And wk2.Range("A" & k) <> "" Then
                    wk2.Range("F" & k) = dic(wk2.Range("A" & k).Value)
                End If
        Next k
      
        dic.RemoveAll
      
End Sub

 

[shinigamilight]

Sub testing()
        Dim wk1, wk2 As Worksheet
        Dim lr, lr2 As Long
        Set wk1 = Workbooks("Report.xlsx").Sheets("Page1")
        Set wk2 = Workbooks("Maandafsluiting.xlsx").Sheets("Blad1")
        Dim k As Integer
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        lr = wk1.Range("A" & Rows.Count).End(xlUp).Row
        lr2 = wk2.Range("A" & Rows.Count).End(xlUp).Row
      
        For k = 3 To lr
                If Not dic.Exists(wk1.Range("A" & k).Value) And wk1.Range("A" & k) <> "" Then
                    dic(wk1.Range("A" & k).Value) = wk1.Range("R" & k).Value
                End If
        Next k
      
        For k = 3 To lr2
                If dic.Exists(wk2.Range("A" & k).Value) And wk2.Range("A" & k) <> "" Then
                    wk2.Range("F" & k) = dic(wk2.Range("A" & k).Value)
                End If
        Next k
      
        dic.RemoveAll
      
End Sub

Now try

 

[ASadStudent]

Sub testing()
        Dim wk1, wk2 As Worksheet
        Dim lr, lr2 As Long
        Set wk1 = Workbooks("Report.xlsx").Sheets("Page1")
        Set wk2 = Workbooks("Maandafsluiting.xlsx").Sheets("Blad1")
        Dim k As Integer
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        lr = wk1.Range("A" & Rows.Count).End(xlUp).Row
        lr2 = wk2.Range("A" & Rows.Count).End(xlUp).Row
     
        For k = 3 To lr
                If Not dic.Exists(wk1.Range("A" & k).Value) And wk1.Range("A" & k) <> "" Then
                    dic(wk1.Range("A" & k).Value) = wk1.Range("R" & k).Value
                End If
        Next k
     
        For k = 3 To lr2
                If dic.Exists(wk2.Range("A" & k).Value) And wk2.Range("A" & k) <> "" Then
                    wk2.Range("F" & k) = dic(wk2.Range("A" & k).Value)
                End If
        Next k
     
        dic.RemoveAll
     
End Sub

Now try

It still isn't working.

 

[ASadStudent]

The code seems to work if I change Value with formula.
Now I only need to add the part where if the code in the A Column isn't found it becomes red.

Sub testing()
        Dim wk1, wk2 As Worksheet
        Dim lr, lr2 As Long
        Set wk1 = Workbooks("Report.xlsx").Sheets("Page1")
        Set wk2 = Workbooks("Maandafsluiting.xlsx").Sheets("Blad1")
        Dim k As Integer
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        lr = wk1.Range("A" & Rows.Count).End(xlUp).Row
        lr2 = wk2.Range("A" & Rows.Count).End(xlUp).Row
      
        For k = 3 To lr
                If Not dic.Exists(wk1.Range("A" & k).Formula) And wk1.Range("A" & k) <> "" Then
                    dic(wk1.Range("A" & k).Formula) = wk1.Range("R" & k).Formula
                End If
        Next k
      
        For k = 3 To lr2
                If dic.Exists(wk2.Range("A" & k).Formula) And wk2.Range("A" & k) <> "" Then
                    wk2.Range("F" & k) = dic(wk2.Range("A" & k).Formula)
                End If
        Next k
      
        dic.RemoveAll
      
End Sub

 

[shinigamilight]

In which workbook you want the color to go red explain in detail.