Copy data to new sheet on meeting criteria

css0911

Board Regular
Joined
Sep 10, 2013
Messages
127
Dear All

Please help me in this scenario.

I have a master data sheet. Sample as below.

ABCD
1Input Date20/01/2018
2Sr.No.Emp. NameGate1Gate2
31Thomas20/01/201801/02/2018
42Bobby`10/03/201820/01/2018
53Kim20/01/201820/01/2018

<tbody>
</tbody>

Column C&D shows the gatepass expiry date for respective gates.
User will input the expiry date in B1

Using this sheet i want to generate two sheets showing the matching expiry dates for two gates

Output sheet for Gate 1

ABc
1Sr.NoEmp. NameGate1
21Thomas20/01/2018
32Kim20/01/2018

<tbody>
</tbody>

Output sheet for Gate 2
ABC
1Sr.NoEmp.NameGate2
21Bobby20/01/2018
32Kim20/01/2018

<tbody>
</tbody>

Please help me with a vb code

Thanks in advance.

CSS
 

Some videos you may like

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.

L. Howard

Well-known Member
Joined
Oct 16, 2012
Messages
4,514
Try this copied to a standard module. Where you have two sheets named Gate 1 and Gate 2.
Run the code on your Master sheet, where I have your example data items Input Date and 20/01/2018 in cells A1 and B1 with the other data following as you posted.

I get Bobby and Kim Sr.No's as 2 & 3 for Gate 2.

Howard


Code:
Sub css0911_Copy()
Dim oneRng As Range, twoRng As Range
Dim c As Range, cc As Range
Dim aDte$

Set oneRng = Sheets("Sheet3").Range("C3:C" & Cells(Rows.Count, "C").End(xlUp).Row)
Set twoRng = Sheets("Sheet3").Range("D3:D" & Cells(Rows.Count, "D").End(xlUp).Row)

aDte = Sheets("Sheet3").Range("B1")

For Each c In oneRng

    If c = aDte Then
      c.Offset(0, -2).Resize(1, 2).Copy Sheets("Gate 1").Range("A" & Rows.Count).End(xlUp)(2)
      Sheets("Gate 1").Range("C" & Rows.Count).End(xlUp)(2) = aDte
  
    End If

Next

For Each cc In twoRng

    If cc = aDte Then

      cc.Offset(0, -3).Resize(1, 2).Copy Sheets("Gate 2").Range("A" & Rows.Count).End(xlUp)(2)
      Sheets("Gate 2").Range("C" & Rows.Count).End(xlUp)(2) = aDte
  
    End If

Next

End Sub
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,122,464
Messages
5,596,288
Members
414,052
Latest member
Dual Showman

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