Macro to copy a number to other sheet based on two conditions

[PSV86]

<tbody></tbody>

Hello there!

I’m just breaking my brains to do this and I ask your help!

I made it without a problem using match and index but is really slow and I want to try it with a macro.

Two sheets, one called Data, and other called Report.

Data has 3 columns, A contains a date, B contains a name, and C (that’s the important one, contains a number) and it has a lot of rows with information.

Reports contains 9 columns
A is equal a different names
B to I are iqual to dates

So I have something like that:

Data:

12/12/17	Name 1	8
12/13/17	Name 1	6
12/15/17	Name 2	8
12/15/17	Name 7	5

<tbody>
</tbody>

Report:

Name	12/13/17	12/14/17	12/15/17	12/16/17	12/17/17	12/18/17	12/19/17	12/20/17
Name 1
Name 2
Name 3
Name 4
Name 5
Name 6
Name 7
Name 8
Name 9

<tbody>
</tbody>

So what I need?
If the date and the name in the Data sheet, is the same as the date and the name in Report, then copy the number.

Using the example posted the result it will be:

Name	12/13/17	12/14/17	12/15/17	12/16/17	12/17/17	12/18/17	12/19/17	12/20/17
Name 1	6
Name 2			8
Name 3
Name 4
Name 5
Name 6
Name 7			5
Name 8
Name 9

<tbody>
</tbody>

The formula in the sheet Report in B2 (and so on) used to achieve this results is:
{=IFNA(INDEX(Data!$A:$C,MATCH(1,(Data!$B:$B=$A2)*(Data!$A:$A=B$1),0),3),0)}

I hope you can help me and learn how to do it in the process examining the reply’s!

Thanks a lot!!

 

[MickG]

Try this for Update on Sheet "Report".

[COLOR="Navy"]Sub[/COLOR] MG15Dec12
[COLOR="Navy"]Dim[/COLOR] n           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Ac          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic         [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Q           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Ray         [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] nRay        [COLOR="Navy"]As[/COLOR] Variant
 Ray = Sheets("Report").Cells(1).CurrentRegion
    [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
    [COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
      [COLOR="Navy"]If[/COLOR] Not Dic.exists(Ray(n, 1)) [COLOR="Navy"]Then[/COLOR]
         [COLOR="Navy"]Set[/COLOR] Dic(Ray(n, 1)) = CreateObject("Scripting.Dictionary")
      [COLOR="Navy"]End[/COLOR] If
      [COLOR="Navy"]For[/COLOR] Ac = 2 To UBound(Ray, 2)
            [COLOR="Navy"]If[/COLOR] Not Dic(Ray(n, 1)).exists(Ray(1, Ac)) [COLOR="Navy"]Then[/COLOR]
                Dic(Ray(n, 1)).Add (Ray(1, Ac)), Array(n, Ac)
            [COLOR="Navy"]End[/COLOR] If
     [COLOR="Navy"]Next[/COLOR] Ac
   [COLOR="Navy"]Next[/COLOR] n
 
nRay = Sheets("Data").Cells(1).CurrentRegion.Resize(, 3)
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(nRay, 1)
    [COLOR="Navy"]If[/COLOR] Dic.exists(nRay(n, 2)) [COLOR="Navy"]Then[/COLOR]
        Q = Dic(nRay(n, 2)).Item(nRay(n, 1))
        Ray(Q(0), Q(1)) = nRay(n, 3)
    [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]Next[/COLOR] n

[COLOR="Navy"]With[/COLOR] Sheets("Report").Range("A1").Resize(UBound(Ray, 1), UBound(Ray, 2))
    .Value = Ray
    .Borders.Weight = 2
    .Columns.AutoFit
 [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[JLGWhiz]

Don't know that looping is much faster than formulas but give this a try.

Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range, fn As Range
Set sh1 = Sheets("Data")
Set sh2 = Sheets("Report")
    For Each c In sh1.Range("B2", sh1.Cells(Rows.Count, 2).End(xlUp))
        Set fn = sh2.Range("1:1").Find(c.Offset(, -1).Value, , xlValues)
            If Not fn Is Nothing Then
                c.Copy sh2.Cells(Rows.Count, 1).End(xlUp)(2)
                c.Offset(, 1).Copy sh2.Cells(Rows.Count, 1).End(xlUp).Offset(, fn.Column - 1)
            End If
    Next
End Sub

 

[PSV86]

Thanks @MickG and @JLGWhiz for the fast reply's and the solutions!

I'm testing both codes I have a few doubts about it.
@MickG your code seems to be working as I suggested, my only concerns are:
- What if in the future want to add some rows above and the introduction of text doesn't start in B2 and starts in B6, how can adapt the code?
- I saw in the code some reference about a dictionary and December, I tested it with January dates and the code shows an error in: Ray(Q(0), Q(1)) = nRay(n, 3)
@JLGWhiz
I tried to run your code but it's creating me a new line with the first name it founds if the criteria matches, and that's it, I don't know if I'm making something wrong.

Thanks again!

 

[MickG]

Can you show an example of your possible data alterations and I will Modify the code and comment on any code modifications.

 

[PSV86]

The almost final version is something like that:

https://ibb.co/hGagkR

The end date contains a formula =today, the start date contains another I1-7
The dates headers are formulas, G1, B4+1 and so on.

So if a day passed the headers changes, aren’t always the same.

Can you show an example of your possible data alterations and I will Modify the code and comment on any code modifications.

 

[MickG]

I've altered the code to start the dates row in row 4.
NB:- Each time you run the code the code will delete previous results from sheet "Report", and provide new results based on current dates in row 4 and "Names" in column "A".

[COLOR="Navy"]Sub[/COLOR] MG15Dec55
[COLOR="Navy"]Dim[/COLOR] n           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Ac          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic         [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Q           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Rng         [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nRng        [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]With[/COLOR] Sheets("Report")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("A4", .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
Rng.Offset(1, 1).Resize(, 8).ClearContents
 [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
 
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
      [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
         [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
      [COLOR="Navy"]End[/COLOR] If
      [COLOR="Navy"]For[/COLOR] Ac = 1 To 8
            [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).exists(Rng(1).Offset(, Ac).Value) [COLOR="Navy"]Then[/COLOR]
                Dic(Dn.Value).Add (Rng(1).Offset(, Ac).Value), Array(Dn, Ac)
            [COLOR="Navy"]End[/COLOR] If
     [COLOR="Navy"]Next[/COLOR] Ac
   [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]With[/COLOR] Sheets("Data")
    [COLOR="Navy"]Set[/COLOR] nRng = .Range("B1", .Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] nRng
  [COLOR="Navy"]If[/COLOR] Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        Q = Dic(Dn.Value).Item(Dn.Offset(, -1).Value)
        Q(0).Offset(, Q(1)).Value = Dn.Offset(, 1).Value
    [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[PSV86]

It works simply amazingly, I tested it with various dates replacing manualy just to check any scenario and it’s insanely faster than the formulas in each cell.

I will check this code and try to understand every bit of it. But thank you for this!

 

[PSV86]

@MickG
Randonmy I’m getting the error “Run-time error 13: type mismatch”
Refered to:
Q(0).Offset(, Q(1)).Value = Dn.Offset(, 1).Value.

How can I debug this error to see what’s going on?

I’m trying to see a pattern for this error

 

[PSV86]

Ok Got it what’s going on.
If in the data list contains a date and this date it isn’t in Report headers it shows this error.
The data list is raw data it contains historical data not only actual data.