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

P

PSV86

New Member
Joined
Dec 15, 2017
Messages
8
[TABLE="width: 500"]
<tbody></tbody>[/TABLE]
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:
[TABLE="width: 500"]
<tbody>[TR]
[TD]12/12/17[/TD]
[TD]Name 1[/TD]
[TD]8[/TD]
[/TR]
[TR]
[TD]12/13/17[/TD]
[TD]Name 1[/TD]
[TD]6[/TD]
[/TR]
[TR]
[TD]12/15/17[/TD]
[TD]Name 2[/TD]
[TD]8[/TD]
[/TR]
[TR]
[TD]12/15/17[/TD]
[TD]Name 7[/TD]
[TD]5[/TD]
[/TR]
</tbody>[/TABLE]

Report:
[TABLE="width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD]12/13/17[/TD]
[TD]12/14/17[/TD]
[TD]12/15/17[/TD]
[TD]12/16/17[/TD]
[TD]12/17/17[/TD]
[TD]12/18/17[/TD]
[TD]12/19/17[/TD]
[TD]12/20/17[/TD]
[/TR]
[TR]
[TD]Name 1
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 2[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 3[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 4[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 5[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 6[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 7[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 8[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 9[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]



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:
[TABLE="width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD]12/13/17[/TD]
[TD]12/14/17[/TD]
[TD]12/15/17[/TD]
[TD]12/16/17[/TD]
[TD]12/17/17[/TD]
[TD]12/18/17[/TD]
[TD]12/19/17[/TD]
[TD]12/20/17[/TD]
[/TR]
[TR]
[TD]Name 1
[/TD]
[TD]6[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 2
[/TD]
[TD][/TD]
[TD][/TD]
[TD]8[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 3[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 4[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 5[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 6[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 7[/TD]
[TD][/TD]
[TD][/TD]
[TD]5[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 8[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 9[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

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!!
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
Sort by date Sort by votes
Try this for Update on Sheet "Report".
Code: 
[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
 
Upvote 0
Don't know that looping is much faster than formulas but give this a try.

Code: 
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
 
Upvote 0
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!
 
Upvote 0
Can you show an example of your possible data alterations and I will Modify the code and comment on any code modifications.
 
Upvote 0
The almost final version is something like that:

hGagkR
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.

MickG said:
Can you show an example of your possible data alterations and I will Modify the code and comment on any code modifications.
Click to expand...
 
Upvote 0
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".
Code: 
[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
 
Upvote 0
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!
 
Upvote 0
@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
 
Upvote 0
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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question Question
Locate first instance of all dates in a column and hide all remaining rows
Replies
4
Views
87
Peter_SSs
Peter_SSs
A
  • Solved
Count entry by time
Replies
3
Views
194
admvlad
A
K
  • Question Question
Compress consecutive numbers
Replies
9
Views
371
Fuji
F
D
  • Question Question
If formula with date & VLOOKUP
Replies
1
Views
283
etaf
etaf
E
  • Question Question
Formula to Covert date into a specific day of the week
Replies
2
Views
84
rpaulson
rpaulson

Forum statistics

Threads
1,223,911
Messages
6,175,337
Members
452,637
Latest member
Ezio2866

Share this page

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
Back
Top