VBA to copy non-sequential columns to new workbook, only unique values

[siunnicuaid]

I'm trying to create a macro which will copy the unique values in Columns F and X from a worksheet (Data) to a new workbook where column C = Yes.

Below is copying the entire Data sheet into the new workbook - how do I set the range (rData) to only columns F and X (and only copy a unique value).

Sub CreateDistribution()

Dim ws     As Worksheet

Dim wsNew  As Workbook

Dim rData  As Range

Dim sfilename As String

Dim dDate As String


Set ws = ThisWorkbook.Sheets("Data")

With ws

Set rData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 24).End(xlUp))
.Columns(.Columns.Count).Clear
.Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopytoRange:=.Cells(1, .Columns.Count), Unique:=True


Set wsNew = Workbooks.Add
dDate = Format(Now, "yyyymmd")
sfilename = "ManagerDistribution" & " " & dDate & ".xlsx"


ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sfilename

Application.DisplayAlerts = False

ws.Activate

rData.AutoFilter Field:=3, Criteria1:="Yes"

rData.Copy
Workbooks(sfilename).Activate
ActiveSheet.Paste

ActiveWorkbook.Close SaveChanges:=True

Application.DisplayAlerts = True

End With

ws.Columns(Columns.Count).ClearContents

rData.AutoFilter

End Sub

 

[Fluff]

Hi & welcome to MrExcel.
Can cols F & X contain the same values?
Also do you want the results in one column or two?

 

[siunnicuaid]

Hi & welcome to MrExcel.
Can cols F & X contain the same values?
Also do you want the results in one column or two?

No, F and X are different. F contains a name and X an email address, so I'm looking for the unique values across two columns - as though I de-duplicated them.

I want the results in 2 columns on my new workbook

Thanks for your help - I'm not great at VBA and totally lost!

 

[Fluff]

So if you had the same name in col F with different emails in X they should be kept?

 

[siunnicuaid]

Sorry for the late reply - Yes - for each unique value for F, X can differ, so I'd need the combinations pasted over to the new sheet.

The data could look like

Column F	Column X
Bob	bob1@gmail
Mary	mary@gmail
Susy	susy@gmail
Bob	bob2@gmail
Mary	mary@gmail

 

[Fluff]

Ok, how about

Sub siunnicuaid()
   Dim wsData As Worksheet
   Dim Wbk As Workbook
   Dim UsdRws As Long
   
   Set wsData = ThisWorkbook.Sheets("Data")
   Set Wbk = Workbooks.Add
   
   Wbk.SaveAs "ManagerDistribution" & Format(Date, "yyyymmd") & ".xlsx", 51
   
   With wsData
      UsdRws = .Range("F" & Rows.Count).End(xlUp).Row
      .Range("F1:F" & UsdRws & ",X1:X" & UsdRws).Copy Wbk.Sheets(1).Range("A1")
   End With
   With Wbk.Sheets(1)
      .Range("A1:B" & UsdRws).RemoveDuplicates Array(1, 2), xlYes
   End With
   Wbk.Close True
End Sub