Copy Columns based on Header > Paste to a new Excel File

[stseia]

Hello Guys, pretty new here and definitely new to Macros. I am hoping to ask for your help on a possible code that I could use that would hopefully make my work so much easier. Apologies if my details are vague or quite complicated, but here goes, allow me to share the steps that I do manually:

1. First I open up a source file where all data are provided containing but not limited to: Employee's Unique Number, Employee's Full Name, Position and many many more.
2. I determine the report needed from me:

Every Report requires different data from the source file, for example:​

Report 1 would need only: Employee's Unique Number and Name​

Report 2 would need Employee's Unique Number, Employee's Full Name, Position and so on.​

Basically every report would require different data from the source file, hence different columns would need to be copied per report.​

3. I will search for the needed columns for the specific reports and paste them one by one to a new Excel File.
4. Save file.

Features that I think would be helpful:
1. Needed columns will be automatically determined from a dropdown (Based on the Name of the Report)
2. Every report would have different column headers assigned to them (hopefully in a list or table that can be easily edited and be expanded for future purposes in case more reports are needed from me or more columns are added to the source file).
3. Based on the Selected Report from Dropdown, needed headers to be copied are automatically identified and pasted into a new excel file.

In case some things are unclear, or things that I need to know to make these things possible please feel free to let me know.
Thank you for sharing your valuable time with me, cheers!

 

[kevin9999]

@kevin9999 apologies for making things difficult, unfortunately there is no way for me to copy all the headers as it is too many, and sadly I cannot get a local copy of my own of the file on the Office Device due to some flash drive restrictions and data privacy concerns. Is there any other way I can help you with to make this possible?

Try selecting the headers, right-click, copy & paste them into your next post. Worth a try.

 

[kevin9999]

This will be my final attempt to provide a solution without actually seeing your data. You can always create a new Excel file that comprises nothing but the headers on sheet1 and post it here using the XL2BB add in. I've added to the code a routine that will delete columns with duplicate headers (starts from the right & works left) as well as a method of sorting the columns according to whatever you determine you want on sheet2.

Option Explicit
Sub Reports_V3()
    Application.ScreenUpdating = False
    Dim Ws1 As Worksheet, Ws2 As Worksheet
    Set Ws1 = Worksheets("Sheet1")
    Set Ws2 = Worksheets("Sheet2")
    
    Dim LRow As Long, Rng1 As Range
    LRow = Ws2.Cells(Rows.Count, 2).End(3).Row
    Set Rng1 = Ws2.Range("B2:B" & LRow)
    
    Dim Wb As Workbook, Ws3 As Worksheet
    Ws1.Copy
    Set Wb = ActiveWorkbook
    Set Ws3 = Wb.Worksheets("Sheet1")
    
    Dim LCol As Long
    LCol = Ws3.Cells(1, Columns.Count).End(xlToLeft).Column
    
    Dim i As Long
    For i = LCol To 1 Step -1
        If WorksheetFunction.CountIf(Rng1, Ws3.Cells(1, i)) = 0 _
        Or WorksheetFunction.CountIf(Ws3.Range("1:1"), Ws3.Cells(1, i)) > 1 _
        Then Ws3.Cells(1, i).EntireColumn.Delete
    Next i
    
    LCol = Ws3.Cells(1, Columns.Count).End(xlToLeft).Column
    Application.AddCustomList ListArray:=Ws2.Range("B2:B" & LRow).Value
    With Ws3.Sort
        .SortFields.Clear
        .SortFields.Add2 Key:=Range(Ws3.Cells(1, 1), Ws3.Cells(1, LCol)), _
        CustomOrder:=Application.CustomListCount
        .SetRange Ws3.Range("A1").CurrentRegion
        .Orientation = xlLeftToRight
        .Apply
    End With
    
    Ws3.Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True
    
    Dim NewName As String, FName
    NewName = "New Report - change to suit"
    FName = Application.GetSaveAsFilename(InitialFileName:=NewName, _
    FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Save As")
    If FName = False Then Exit Sub
    Wb.SaveAs Filename:=FName, FileFormat:=51
    
End Sub

 

[stseia]

@kevin9999 Hello! Apologies for the late response (fell asleep, different time zones I guess). Will try out these once I get to work again later. Again apologies for the troubles and million times, Thank you! Will provide an update later.

 

[stseia]

@kevin9999 thank you so much I have tried this one, and everything is working perfectly! thank you for helping me on this one, just in case I have some future troubles I'll let you know.

 

[kevin9999]

@kevin9999 thank you so much I have tried this one, and everything is working perfectly! thank you for helping me on this one, just in case I have some future troubles I'll let you know.

Glad we got there in the end, and thanks for the feedback