Export Selected Columns to a New Workbook

[HangMan]

I would like to be able to run a macro that exports (moves a copy) a single WorkSheet from a Workbook into a standalone Workbook, but I only want selected columns exported. The exported worksheet needs five things:

1. To have the same worksheet name
2. To have the header row frozen and filter arrows in place automatically
3. For the exported columns to be adjacent to each other
4. All values in the exported worksheet to be Paste Values to avoid any links to the original file
5. All cell formatting to remain in place, so header row colours, conditional formattting etc., i.e. Paste Format

I've attached a simple example, the main sheet shows how the original sheet would look, the second sheet shows how the exported file should look, so in the example, it is only the columns with red headers that should then appear in the exported file.

The main sheet has around 70 columns, but I'm happy to specify these in the code as these may change over time.

Many thanks

[ranman256]

did you try it yourself by start recording a macro, do the events, stop the macro?

[HangMan]

Yes, but that doesn't give me what I need because I can't see any way of specifying the columns to be exported using this method.

[JBeaucaire]

Maybe something like this:

Option Explicit

Sub ExportSubReport()
Dim fPATH As String

fPATH = ThisWorkbook.Path & Application.PathSeparator
With ThisWorkbook.Sheets("Master")
    .Copy
End With
With ActiveSheet
    .UsedRange.Cells.Value = .UsedRange.Cells.Value
    .Range("B:B, D:F, I:I").EntireColumn.Delete xlShiftToLeft
End With

ActiveWorkbook.SaveAs fPATH & "Master - " & Format(Date, "mmm dd yyyy") & ".xlsx", 51
End Sub

I've noted in red where we deleted the unwanted columns in the new sheet. Edit that to include all the columns you want deleted. This saves the new copy in the same folder as the original.

[JOHN H. DAVIS]

Maybe:

Sub HangMan()
Dim ws As Worksheet, wbk As Workbook
Dim i As Long, x As Long, y As Long
x = 0
Set ws = ActiveSheet
Workbooks.Add
Sheets("Sheet1").Name = ws.Name
Set wbk = ActiveWorkbook
With ws
    For i = 1 To ws.UsedRange.Columns.Count
        y = .Cells(Rows.Count, i).End(3).row
        Select Case .Cells(1, i).Value
            Case Is = "No", "Col 3", "Area", "Colour", "Q1", "Q2", "Q3", "Q4"
                x = x + 1
                .Range(.Cells(1, i), .Cells(y, i)).Copy
                wbk.Sheets(ws.Name).Cells(1, x).PasteSpecial xlPasteValues
                .Range(.Cells(1, i), .Cells(y, i)).Copy
                wbk.Sheets(ws.Name).Cells(1, x).PasteSpecial xlPasteFormats
        End Select
    Next i
End With
        
End Sub

[HangMan]

John,

With your approach, is it possible to specify column letters rather than header text?

[JOHN H. DAVIS]

John,

With your approach, is it possible to specify column letters rather than header text?

Select Case i
            Case Is = 1, 3, 5, .....

Will give you the column number. Does that help?

[HangMan]

Hi JB,

Would this sit on the actual sheet, This WorkBook or a module on it's own?

If I wanted to specify a different folder to export the file to, is that possible?

[ptmuldoon]

I like what John is suggesting. I don't think you can actually export just a column. So its a matter of copying the Sheet to the new WB, and then doing the cleanup on the new Sheet.

Should go in Standard Module.

And yes, you can specify a folder path and file name if you would like.

See if this code/post helps with that

You an probably combine the two into one macro.

http://www.excelforum.com/excel-prog...ml#post4159034

Sub SavetoNewFile()
    Dim Message, fName As String
    Dim FileFormatNum As Long
      
    Message = "Copy WorkSheet and Save to New File?"

    If (MsgBox(Message, vbYesNo) = vbNo) Then Exit Sub
    
    ActiveWorkbook.ActiveSheet.Copy
    
    'Prompt User for File Path and File Name
    fName = Application.GetSaveAsFilename(InitialFileName:="", filefilter:= _
        "Excel Workbook (*.xlsx), *.xlsx,", _
        FilterIndex:=1, Title:="Enter A File Name and Save...")
        
    'Save The File
     If fName = "False" Then
        MsgBox "The filename entered was not valid. New Workbook not Created.", vbOKOnly, _
               "Save Cancelled - Invalid File Name"
     Else
        ActiveWorkbook.SaveAs fName, CreateBackup:=False
    End If
End Sub

[JBeaucaire]

Yes, just edit the line code for fPATH and put in the target folder, remember the \ at the end.

fPATH = "C:\My\Folder\ToSave\"

[HangMan]

Hi JB,

I'm slightly unsure where the code needs to sit? If on the actual sheet, then I need to be able to integrate it with some other code, namely:

Dim PreviousValue

Private Sub Worksheet_Change(ByVal Target As Range)
Dim NR As Long

    If ActiveCell.Value <> PreviousValue Then
        With Sheets("log")
            NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
    If NR = 2 Then
        .Range("A2") = 1
    Else
        .Range("A" & NR).FormulaR1C1 = "=R[-1]C + 1"
    End If
            .Range("B" & NR).Value = WorksheetFunction.Trim(Application.UserName & " changed cell " & Target.Address & " from " & PreviousValue & " to " & Target.Value)
            .Range("C" & NR).Value = Date
            .Range("D" & NR).Value = Time
        End With
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim v As Variant

    If Intersect(ActiveCell, Range("AA:AE", "AH:AV")) Is Nothing Then
        v = "N/A"
    Else
        v = ActiveCell.Value
        If v = vbNullString Then v = 0
        Range("DA1").Value = v
    End If

    PreviousValue = ActiveCell.Value
End Sub

but unsure how to go about doing that?

[JBeaucaire]

Those macros are sheet macros in the sheet module. Mine is an "ondemand" macro, place it in a normal code module. (Insert >Module)

[HangMan]

Tried that and for some reason the code then errors because of one of the lines in the sheet macro, namely:

With Sheets("log")

[JBeaucaire]

I don't see that line anywhere. What is the error message?

[HangMan]

Apologies, the error isn't with your code, but there is other code sitting on the Sheet, i.e.

Dim PreviousValue

Private Sub Worksheet_Change(ByVal Target As Range)
Dim NR As Long

    If ActiveCell.Value <> PreviousValue Then
        With Sheets("log")
            NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
    If NR = 2 Then
        .Range("A2") = 1
    Else
        .Range("A" & NR).FormulaR1C1 = "=R[-1]C + 1"
    End If
            .Range("B" & NR).Value = WorksheetFunction.Trim(Application.UserName & " changed cell " & Target.Address & " from " & PreviousValue & " to " & Target.Value)
            .Range("C" & NR).Value = Date
            .Range("D" & NR).Value = Time
        End With
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim v As Variant

    If Intersect(ActiveCell, Range("AA:AE", "AH:AV")) Is Nothing Then
        v = "N/A"
    Else
        v = ActiveCell.Value
        If v = vbNullString Then v = 0
        Range("DA1").Value = v
    End If

    PreviousValue = ActiveCell.Value
End Sub

I appreciate this is nothing to do with your code, which run's perfectly, the problem I now have is that it won't run in conjunction with the code above!

When running your code, it generates a Run-time error '9' Subscript out of Range (i.e. when run in conjunction with the code above). It then highlights the line in red above. Independently, both pieces of code run as expected, together they seem to conflict

[HangMan]

Hi JB,

Strangely running your code works fine 'locally', however, if I run it over our network, it throws up an error message saying:

The following features cannot be saved in a macro-free workbook

.VB Project

unsure if there is a work around for this?

Many thanks