Copy and paste selected data without duplicates

tmdgus

New Member
Joined
Oct 2, 2022
Messages
13
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
Hi, I am new to VBA and need some help with some of the procedures I would like to automate.
I have two excel files to work on - employee and contract data.
Basically, I need to find employees who end their contracts in the current month that I open the file. (For example, if I open the file in August, I need to find employee data who are ending their contract in August). Then, I need to copy the selected data and paste them onto another file, called contract data.

I have completed both identifying and copy+paste, but it doesn't meet some of the requirements I want to apply in my file. I will put my code below.
The code below highlights rows of employee data whose employment contract expires within a month.
VBA Code:
Sub HighlightCalc()
   Dim i As Range
   For Each i In Range("K2:K65565") '// K is the column that contains contract expiry date
      If IsDate(i) Then
         If Month(i) = Month(Now) Then
            Rows(i.Row).Interior.Color = RGB(255,255,91)
            Rows(i.Row).Font.Bold = True
         End If
      End If
   Next i
End Sub

The code below is when I transfer a selected row to another file called Contract Data
VBA Code:
Private Sub CommandButton1_Click()
Dim wb As Workbook
ThisWorkbook.Worksheets("Sheet1").Rows(2).Select    '//Question 1: How do I select rows that I have previously highlighted above?
Selection.Copy

Set wb = Workbooks.Open("file address, didn't put the real address")
wb.Worksheets("Sheet1").Activate
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Cells(lastrow + 1, 1).Select
ActiveSheet.Paste.     '//Question 2: Is there any way that I can only copy "new" data and paste them? Every time I run this Macro, the same data is pasted.
'//Any suggestions on copying data to other files without duplicates?
'//Question 3: Can I only copy selected cells and paste them onto the selected places?
ActiveWorkbook.Save
ActiveWorkbook.Close savechanges = True

Set wb = Nothing
ThisWorkbook.Worksheets("Sheet1").Activate
ThisWorkbook.Worksheets("Sheet1").Cells(1,1).Select
Application.CutCopyMode = False

I have included some questions in the code.
To explain them further, when I copy the data from the Employee file to the Contract File, I do not want to copy the exact same data multiple times.
There is a column that I made for a unique identifier(column A), so I guess there might be a way to do this with it, but I am still clueless about how to do so, as I am not familiar with VBA yet.
I also do not know how to select the highlighted data to copy them to the Contract file.
Most importantly, when copying data, I only want some data to be copied, not all. (For example, I want to copy the name of employees and their positions, but not their addresses or phone number).
When pasting data, I want to paste them onto their allocated cell area.

Can anyone please help me with my VBA? I am new to this and need help ASAP :(
 
Try:
VBA Code:
Sub CopyData()
    Application.ScreenUpdating = False
    Dim FTws As Worksheet, PTws As Worksheet, srcWS As Worksheet
    Set FTws = ThisWorkbook.Sheets("Contract(Full-Time)")
    Set PTws = ThisWorkbook.Sheets("Contract(Part-Time)")
    Set srcWS = ThisWorkbook.Sheets("Staff_Info")
    Dim lastRow As Long, i As Long, header As Range, x As Long
    lastRow = srcWS.Range("L" & srcWS.Rows.Count).End(xlUp).Row
    With srcWS
        .Range("A2").CurrentRegion.AutoFilter Field:=12, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic
        .Range("A2").CurrentRegion.AutoFilter Field:=7, Criteria1:="Monthly"
        With .Range("A:A,B:B,C:C,D:D,F:F,G:G,H:H,I:I,L:L")
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = FTws.Rows(1).Find(.Areas(i).Cells(2), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    Intersect(srcWS.Range(srcWS.Cells(3, x), srcWS.Cells(lastRow, x)), srcWS.AutoFilter.Range).Copy FTws.Cells(FTws.Rows.Count, header.Column).End(xlUp).Offset(1, 0)
                End If
            Next i
        End With
        .Range("A2").CurrentRegion.AutoFilter Field:=12, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic
        .Range("A2").CurrentRegion.AutoFilter Field:=7, Criteria1:="Hourly", Operator:=xlOr, Criteria2:="Daily"
        With .Range("A:A,B:B,C:C,D:D,F:F,G:G,H:H,I:I,L:L")
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = PTws.Rows(1).Find(.Areas(i).Cells(2), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    Intersect(srcWS.Range(srcWS.Cells(3, x), srcWS.Cells(lastRow, x)), srcWS.AutoFilter.Range).Copy PTws.Cells(PTws.Rows.Count, header.Column).End(xlUp).Offset(1, 0)
                End If
            Next i
        End With
    End With
    srcWS.Range("A2").AutoFilter
    Application.ScreenUpdating = True
    FTws.Range("a2:t65565").RemoveDuplicates Columns:=1, header:=xlNo
End Sub
 
Upvote 0

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Hi, Thank you so much for your help!!
Everything works perfectly except that Column L of Sheet1 isn't pasted to Column H of Sheet2.
Do you have any ideas on how to fix this issue??
Thank you for your help so far! I really appreciate it :)
 
Upvote 0
This is the result table(sheet2) when I run CopyData() function.
As you can see data are pasted well, except column H, contract start date.
Could you please help me how to paste column L of sheet1 to column H of sheet2?
Thank you!!
Employment_Contract.xlsm
ABCDEFGHIJKLMNOPQRST
1Staff NumberContract Date(Mr./Ms.)Last NameFirst NameHKIDPositionContract Start DateContract End DateMonthsProbationContract Start DateProbation End DateWorking LocationWorking HourContract TypeSalaryAnnual LeaveSick LeaveHoliday
2PEOCL22001Ms. LamKa HoB7894561Marketing InternMonthlyHKD 65
3PEOCL22004Mr. ChanPui ShanE7539566Finance InternMonthlyHKD 500
4PEOCL22009Mr. LeeXiao YuK9856213ManagerMonthlyHKD 360
Contract(Full-Time)
Cells with Data Validation
CellAllowCriteria
J1List3,6,9,12
K1List0,3,6
N1ListYou will be working in the office or a place designated by the Company or the Company’s designated client.
O1ListMonday to Friday 9:00 a.m. – 6:00 p.m. (Subject to the company’s requirements and mutual agreement. Actual working days may change if needed)
R1ListYou will be entitled to annual leave benefits in accordance with the provisions under the Hong Kong Employment Ordinance.
S1ListYou will be entitled to sick leave benefits in accordance with the provisions under the Hong Kong Employment Ordinance.
T1ListYou will be entitled to public holidays in accordance with the provisions under the Hong Kong Employment Ordinance.,You will be entitled to Statutory Holidays in accordance with the provisions under the Hong Kong Employment Ordinance.
C2:C4ListMr. ,Ms.
F2:F4Text length=8
P2:P4ListDaily,Hourly,Monthly
 
Upvote 0
Try:
VBA Code:
Sub CopyData()
    Application.ScreenUpdating = False
    Dim FTws As Worksheet, PTws As Worksheet, srcWS As Worksheet
    Set FTws = ThisWorkbook.Sheets("Contract(Full-Time)")
    Set PTws = ThisWorkbook.Sheets("Contract(Part-Time)")
    Set srcWS = ThisWorkbook.Sheets("Staff_Info")
    Dim lastRow As Long, i As Long, header As Range, x As Long
    lastRow = srcWS.Range("L" & srcWS.Rows.Count).End(xlUp).Row
    With srcWS
        .Range("A2").CurrentRegion.AutoFilter Field:=12, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic
        .Range("A2").CurrentRegion.AutoFilter Field:=7, Criteria1:="Monthly"
        With .Range("A:A,B:B,C:C,D:D,F:F,G:G,H:H,I:I")
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = FTws.Rows(1).Find(.Areas(i).Cells(2), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    Intersect(srcWS.Range(srcWS.Cells(3, x), srcWS.Cells(lastRow, x)), srcWS.AutoFilter.Range).Copy FTws.Cells(FTws.Rows.Count, header.Column).End(xlUp).Offset(1, 0)
                End If
            Next i
            srcWS.AutoFilter.Range.Offset(1).Columns(12).Copy FTws.Cells(FTws.Rows.Count, "H").End(xlUp).Offset(1)
        End With
        .Range("A2").CurrentRegion.AutoFilter Field:=12, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic
        .Range("A2").CurrentRegion.AutoFilter Field:=7, Criteria1:="Hourly", Operator:=xlOr, Criteria2:="Daily"
        With .Range("A:A,B:B,C:C,D:D,F:F,G:G,H:H,I:I,L:L")
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = PTws.Rows(1).Find(.Areas(i).Cells(2), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    Intersect(srcWS.Range(srcWS.Cells(3, x), srcWS.Cells(lastRow, x)), srcWS.AutoFilter.Range).Copy PTws.Cells(PTws.Rows.Count, header.Column).End(xlUp).Offset(1, 0)
                End If
            Next i
        End With
    End With
    srcWS.Range("A2").AutoFilter
    Application.ScreenUpdating = True
    FTws.Range("a2:t65565").RemoveDuplicates Columns:=1, header:=xlNo
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,215
Members
448,554
Latest member
Gleisner2

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