[VBA] Copy/Paste different values based on date

Yooks

New Member
Joined
Apr 2, 2021
Messages
9
Office Version
  1. 365
Platform
  1. Windows
Hi peeps,

I want a VBA that will automatically copy/paste data from sheet1 to sheet2.​
It should copy the Oracle value(D4:D8), Name(E4:E8), Code(F4:F8) and the date of the day (F2).​
So in example below. I have 4 agents, they were all present on April 2nd.​
I now want to move all that data onto sheet2 in the sheet below.​
Now when we get to tomorrow I want it to copy the same but for April 3rd (G2).​
It should not overwrite any additional data. It should not copy the data if the code cell is blank (F4:F8)​

EXCEL_RDLK7aTy8K.png


1617404573984.png
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
20,147
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows
Maybe this then
VBA Code:
Sub MM1()
 Dim lr As Long, lr2 As Long, r As Long, ws1 As Worksheet, ws2 As Worksheet
 Set ws1 = Sheets("Sheet1")
 Set ws2 = Sheets("Sheet2")
 lr = ws1.Cells(Rows.Count, "D").End(xlUp).Row
 lr2 = ws2.Cells(Rows.Count, "D").End(xlUp).Row
 With ws1
     For r = 4 To lr
        If .Cells(r, 6).Value = "P" Then
            .Range(Cells(r, 4), Cells(r, 6)).Copy ws2.Cells(lr2 + 1, 4)
            lr2 = ws2.Cells(Rows.Count, "D").End(xlUp).Row
        End If
    Next r
End With
End Sub
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
20,147
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows
Sorry , a typo in there....Try
VBA Code:
Sub MM1()
 Dim lr As Long, lr2 As Long, r As Long, ws1 As Worksheet, ws2 As Worksheet
 Set ws1 = Sheets("Sheet1")
 Set ws2 = Sheets("Sheet2")
 lr = ws1.Cells(Rows.Count, "D").End(xlUp).Row
 lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
 With ws1
     For r = 4 To lr
        If .Cells(r, 6).Value = "P" Then
            .Range(Cells(r, 4), Cells(r, 6)).Copy ws2.Cells(lr2 + 1, 1)
            ws2.Cells(lr2 + 1, 4).Value = .Cells(2, 6)
            lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
        End If
    Next r
End With
End Sub
 

Yooks

New Member
Joined
Apr 2, 2021
Messages
9
Office Version
  1. 365
Platform
  1. Windows
Sorry , a typo in there....Try
VBA Code:
Sub MM1()
Dim lr As Long, lr2 As Long, r As Long, ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
lr = ws1.Cells(Rows.Count, "D").End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
With ws1
     For r = 4 To lr
        If .Cells(r, 6).Value = "P" Then
            .Range(Cells(r, 4), Cells(r, 6)).Copy ws2.Cells(lr2 + 1, 1)
            ws2.Cells(lr2 + 1, 4).Value = .Cells(2, 6)
            lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
        End If
    Next r
End With
End Sub

Hello,

Thank you very much for the help.

This is what we have so far.

1617407031489.png


So it has successfully moved the data from Sheet1 to Sheet 2.

I should clarify that column D containing the Oracle values will be a index match formula. So I assume once I use on real data it will copy the formula?

I would also need it copy from the column that matches the present date.

So today, the correct date column if F. Tomorrow it will be G. How do I make it search for =TODAY() IN 3:3 to then pull the rest of the data from the rows in that column?
Also Values in the code column can vary between 5 different values. In this case "P", "WO", "PTO", "NCNS", "ABSENT"
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
20,147
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows

ADVERTISEMENT

Ok, I'd suggest giving us ALL the required information rather than adding further criteria as we go....it just means we will be constantly rewriting the code to suit new requirements.
Have a look at using the XL2BB download in my tag and posting using it , rather than posting pictures that we can't use to test the data.
 

Yooks

New Member
Joined
Apr 2, 2021
Messages
9
Office Version
  1. 365
Platform
  1. Windows
Ok, I'd suggest giving us ALL the required information rather than adding further criteria as we go....it just means we will be constantly rewriting the code to suit new requirements.
Have a look at using the XL2BB download in my tag and posting using it , rather than posting pictures that we can't use to test the data.

Thank you for the suggestion. I have set up XL2BB. You can see the below table. Grateful for your knowledge and help with this!

NCNS And Absent will have a simple =Countif - But since they're not needed in this task I have left out their formulas.

As you can see below. We have data for April 2nd. Now it is April 3rd we would want to copy from that column.

AbsenseTest.xlsm
ABCDEFGHIJKLMNOP
1
2Agent Overview02-Apr03-Apr04-Apr05-Apr06-Apr07-Apr08-Apr09-Apr10-Apr11-Apr12-Apr
3NCNSAbsentOracleNameFriSatSunMonTueWedThuFriSatSunMon
41234Sample NamePP
512345Sample Name 1PP
612346Sample Name 2PNCNS
712347Sample Name 3PP
812348Sample Name 4PWO
9
10
Sheet1
Cell Formulas
RangeFormula
G2:P2G2=F2+1
F3:P3F3=TEXT(F2,"DDD")
D4:D8D4=INDEX(ALL[#All],MATCH(Sheet1!E4,ALL!$E$3:$E$144,0)+1,2)
Cells with Data Validation
CellAllowCriteria
F4:P8ListP,WO,PTO,NCNS,ABSENT
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
20,147
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows

ADVERTISEMENT

edit....misread
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
20,147
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows
UNTESTED
VBA Code:
Sub MM1()
 Dim lr As Long, lr2 As Long, r As Long, ws1 As Worksheet, ws2 As Worksheet
 Dim lc As Integer
 Set ws1 = Sheets("Sheet1")
 Set ws2 = Sheets("Sheet2")
 lc = ws1.Cells(4, Columns.Count).End(xlToLeft).Column
 lr = ws1.Cells(Rows.Count, "D").End(xlUp).Row
 lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
 With ws1
     For r = 4 To lr
        If .Cells(r, lc).Value <> "" Then
            .Range(Cells(r, 4), Cells(r, lc)).Copy ws2.Cells(lr2 + 1, 1)
            ws2.Cells(lr2 + 1, 4).Value = .Cells(2, lc).Value
            lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
        End If
    Next r
End With
End Sub
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
20,147
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows
Another edit
VBA Code:
Sub MM1()
 Dim lr As Long, lr2 As Long, r As Long, ws1 As Worksheet, ws2 As Worksheet
 Dim lc As Integer
 Set ws1 = Sheets("Sheet1")
 Set ws2 = Sheets("Sheet2")
lc = Evaluate("COUNTIF(D4:P4,""<>"")") + 3
 lr = ws1.Cells(Rows.Count, "D").End(xlUp).Row
 lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
 With ws1
     For r = 4 To lr
        If .Cells(r, lc).Value <> "" Then
            .Range(Cells(r, 4), Cells(r, lc)).Copy ws2.Cells(lr2 + 1, 1)
            ws2.Cells(lr2 + 1, 4).Value = .Cells(2, lc).Value
            lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
        End If
    Next r
End With
End Sub
 

Yooks

New Member
Joined
Apr 2, 2021
Messages
9
Office Version
  1. 365
Platform
  1. Windows
Thanks for the help Michael. I have edited the code a little.

So what this does now is checks to see weather the row matching the date column has data.
Then it will proceed to paste column 4(D) and 5(E).

I have also made it so it will paste Today() in the 4th(D) column in Sheet2

VBA Code:
Sub MM1()
 Dim lr As Long, lr2 As Long, r As Long, ws1 As Worksheet, ws2 As Worksheet
 Dim lc As Integer
 Set ws1 = Sheets("Sheet1")
 Set ws2 = Sheets("Sheet2")
 lc = Evaluate("MATCH(TODAY(),2:2,0)")
 lr = ws1.Cells(Rows.Count, "E").End(xlUp).Row
 lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
 With ws1
     For r = 4 To lr
        If .Cells(r, lc).Value <> "" Then
            .Range(Cells(r, 4), Cells(r, 5)).Copy
            ws2.Cells(lr2 + 1, 1).PasteSpecial xlPasteValues
            ws2.Cells(lr2 + 1, 4).Value = Evaluate("Today()")
            lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
        End If
    Next r
End With
End Sub

This is the outcome so far

AbsenseTest.xlsm
ABCD
1OracleNameCode Date
212345Sample Name 103/04/2021
Sheet2



Now for the final task. I need a way to paste the "Code" value from the specified date column only. Into sheet 2
For today. That column would be H.

AbsenseTest.xlsm
ABCDEFGH
1
2Agent Overview01-Apr02-Apr03-Apr
3NCNSAbsentOracleNameThuFriSat
41234Sample NamePP
512345Sample Name 1PPP
612346Sample Name 2PNCNS
712347Sample Name 3WOP
812348Sample Name 4PWO
9
10
11
Sheet1
Cell Formulas
RangeFormula
G2:H2G2=F2+1
F3:H3F3=TEXT(F2,"DDD")
D4:D8D4=INDEX(ALL[#All],MATCH(Sheet1!E4,ALL!$E$3:$E$144,0)+1,2)
Cells with Data Validation
CellAllowCriteria
F4:H8ListP,WO,PTO,NCNS,ABSENT
 

Watch MrExcel Video

Forum statistics

Threads
1,129,675
Messages
5,637,733
Members
416,981
Latest member
PLonchar

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
Top