Extract Columns using Column Header to new Workbook

[slucena]

Hello,

I'm new to macro creation and I've been using this macro to extract certain columns from an excel file, copying them to a new workbook and saving it into a specific location.
in case of adding a new column in between, it will mess up the selected range of columns (A:A, Z:Z, DB:DB, DC:DC).
the purpose of the change is to read 4 specific column headers, instead of the mentioned range and execute the rest of the macro.
also, after the creation of the new workbook, is it possible to send the new workbook as an attachment with Outlook?

1. Find and Extract 4 specific columns by header name (new)
2. paste to new workbook
3. save workbook with value of cell A2 in specific location
4. send as attachment with outlook to specific email (new)

Many Thanks in advance if anyone can help me with this one.

Public Sub Extract_columns()

Sheets("HCP Report").Select

Set range1 = Range("A:A, Z:Z, DB:DB, DC:DC")
     range1.Copy
     Set newbook = Workbooks.Add
     ActiveCell.PasteSpecial Paste:=xlPasteValues
   
Dim Path As String
Dim Filename As String

Path = "sharepointLocation"
Filename = Range("A2")
ActiveWorkbook.SaveAs Filename:=Path & Filename & ".xlsx", FileFormat:=51

End Sub

 

[Max1616]

Give this a try! Remember to change the ClmName variables to the columns you'd like pulled over. I hope this helps!

Public Sub Extract_columns()

Dim ClmName1 As String
Dim ClmName2 As String
Dim ClmName3 As String
Dim ClmName4 As String
Dim Clm1 As Integer
Dim Clm2 As Integer
Dim Clm3 As Integer
Dim Clm4 As Integer
Dim ws As Worksheet
Dim NewWb As Workbook
Dim i As Integer
Dim lClm As Integer
Dim Rng As Range
Dim Path As String
Dim Filename As String
Dim Outapp As Object
Dim Outmail As Object

ClmName1 = "ColumnA"
ClmName2 = "ColumnB"
ClmName3 = "ColumnC"
ClmName4 = "ColumnD"

Set ws = Sheets("HCP Report")
lClm = Cells(1, Columns.Count).End(xlToLeft).Column

For i = 1 To lClm
    If Cells(1, i) = ClmName1 Then Clm1 = i
    If Cells(1, i) = ClmName2 Then Clm2 = i
    If Cells(1, i) = ClmName3 Then Clm3 = i
    If Cells(1, i) = ClmName4 Then Clm4 = i
Next i


Set Rng = ws.Range(Cells(1, Clm1).EntireColumn.Address & "," & Cells(1, Clm2).EntireColumn.Address & "," & Cells(1, Clm3).EntireColumn.Address & "," & Cells(1, Clm4).EntireColumn.Address)
Set NewWb = Workbooks.Add


Rng.Copy NewWb.Sheets(1).Range("A1")

Path = "sharepointlocation"
Filename = Range("A2") 'This might need to be tweeked, I'm unsure which wb A2 value you're looking at
ActiveWorkbook.SaveAs Filename:=Path & Filename & ".xlsx", FileFormat:=51


'EMAIL SECTION:

Application.EnableEvents = False
Application.ScreenUpdating = False

Set Outapp = CreateObject("Outlook.Application")
Set Outmail = Outapp.CreateItem(0)
  
With Outmail
    .To = "TestTo@test.com" 'Update recipiants
    .CC = "TestCC@Test.com" 'Update recipiants
    .Subject = "Put Your Subject Here"
    .HTMLBody = "Put Your Email Body Here"
    .Attachments.Add NewWb.FullName
    .Display 'Change this to "Send" if you'd like the email to auto-send
End With

Application.EnableEvents = True
Application.ScreenUpdating = True

Set Outapp = Nothing
Set Outmail = Nothing

End Sub

 

[slucena]

Hi Max1616.

big thanks for your help. it almost work properly.
I added a button to run the macro on a different sheet, along with other macros.

it seems when i try to run it, it returns an error, but if i Run it through the editor works fine.

debug stops here:

 

[Alex Blakenburg]

I added a button to run the macro on a different sheet

This is not the preferred way of handling it but the easiest.
After the line
Set ws = Sheets("HCP Report")
ADD
ws.Select

 

[slucena]

Max1616 and Alex, thank you both.

solved and work perfectly for this specific task.

 

[Alex Blakenburg]

Thanks for letting us know. Glad we could help.