# macro deleting formulas



## ASadStudent (Jan 5, 2023)

*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.xlsxABCDEFGHIJKLMNOPQR1Total2Product codeAmount of times sold325006154210021652501417625012172501748250227926015431026008211260045631213142311644152311723162310131723106657182311289192311172023130221222324006452424001225240044622623507627235084628235014272923504273023132246Page1

Maandafsluiting.xlsxABCDEF1Total2Product codesAantal321001421002165210036210047210058210069Total1022000112200212220041322006142200715220101622012172201418220171922018202202221220232222031232203224Total25231013262310227231032823104292310665730231073123108322310933231117342311289352311644362311723372312138Total3923501427402350241235034223504274323505442350645235076462350846472351148 Total 492400125024003512400446252Total5325006155425008552501215625013572501417582501659250174602502276125060622506163250626425063652506466Total6726002682600456369260082702601071260127226014732601543742601875Total7623130277231317823132246792313380240064581240064582338Blad1Cell FormulasRangeFormulaF82F82=SUM(F76:F81)


----------



## ASadStudent (Monday at 3:27 AM)

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 (Monday at 4:33 AM)

```
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 (Monday at 5:07 AM)

shinigamilight said:


> ```
> Sub testing()
> Dim wk1, wk2 As Worksheet
> Dim lr, lr2 As Long
> ...


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 (Monday at 5:28 AM)

ASadStudent said:


> 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 (Monday at 5:44 AM)

shinigamilight said:


> 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 (Monday at 6:03 AM)

```
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 (Monday at 6:10 AM)

shinigamilight said:


> ```
> Sub testing()
> Dim wk1, wk2 As Worksheet
> Dim lr, lr2 As Long
> ...


 It still isn't working.


----------



## ASadStudent (Monday at 6:28 AM)

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 (Monday at 6:37 AM)

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


----------



## ASadStudent (Jan 5, 2023)

*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.xlsxABCDEFGHIJKLMNOPQR1Total2Product codeAmount of times sold325006154210021652501417625012172501748250227926015431026008211260045631213142311644152311723162310131723106657182311289192311172023130221222324006452424001225240044622623507627235084628235014272923504273023132246Page1

Maandafsluiting.xlsxABCDEF1Total2Product codesAantal321001421002165210036210047210058210069Total1022000112200212220041322006142200715220101622012172201418220171922018202202221220232222031232203224Total25231013262310227231032823104292310665730231073123108322310933231117342311289352311644362311723372312138Total3923501427402350241235034223504274323505442350645235076462350846472351148 Total 492400125024003512400446252Total5325006155425008552501215625013572501417582501659250174602502276125060622506163250626425063652506466Total6726002682600456369260082702601071260127226014732601543742601875Total7623130277231317823132246792313380240064581240064582338Blad1Cell FormulasRangeFormulaF82F82=SUM(F76:F81)


----------



## ASadStudent (Monday at 6:38 AM)

shinigamilight said:


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


I want the numbers that are in the A file of the "report" workbook to become red when they aren't found in "Maandafsluiting" workbook


----------



## shinigamilight (Monday at 7:28 AM)

```
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 store As Long
        Dim tempstore As String
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        Dim v
        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
         
        
           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) = k
                End If
        Next k
        
        For Each v In dic.Keys
                    For k = 3 To lr2
                            tempstore = wk2.Range("A" & k)
                            If tempstore = v Then
                                store = store + 1
                            End If
                    Next k
                        If store = 0 Then
                            wk1.Range("A" & dic(v)).Interior.Color = vbRed
                        End If
                        store = 0
        Next v
        
      
End Sub
```


----------



## ASadStudent (Monday at 8:21 AM)

Thanks a lot for helping me!


----------

