Export data to workbook with criteria with few selected columns

[Hudson Andrew]

Hi all,




I have code which exports data to workbook ( to folder specified in control sheet) code is so far so good the only challenge is i do not want every other roww rather i only few specified row to be exported . out of below 9 colums i only need 5 columns.


Sales Representative Location Region Customer Order Date Item Quantity Price Total Sale Amount




i want below columns to be generated when i say export.


Sales Representative
Region
Item
Quantity
Price





can some one please help tweek below code ?.

Option Explicit


Sub ExportData()
'http://www.howtoexcel.org/
'John MacDougall 2017-05-07


'Declare variables
Dim ArrayItem As Long
Dim ws As Worksheet
Dim ArrayOfUniqueValues As Variant
Dim SavePath As String
Dim ColumnHeadingInt As Long
Dim ColumnHeadingStr As String
Dim rng As Range


'Set the worksheet to
Set ws = Sheets("Data")


'Set the save path for the files created
SavePath = Range("FolderPath")


'Set variables for the column we want to separate data based on
ColumnHeadingInt = WorksheetFunction.Match(Range("ExportCriteria").Value, Range("Data[#Headers]"), 0)
ColumnHeadingStr = "Data[[#All],[" & Range("ExportCriteria").Value & "]]"


'Turn off screen updating to save runtime
Application.ScreenUpdating = False


'Create a temporary list of unique values from the column we want to
'separate our data based on
Range(ColumnHeadingStr & "").AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=Range("UniqueValues"), Unique:=True


'Sort our temporary list of unique values
ws.Range("UniqueValues").EntireColumn.Sort Key1:=ws.Range("UniqueValues").Offset(0, 0), _
    Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom, DataOption1:=xlSortNormal


'Add unique field values into an array
'ArrayOfUniqueValues = Application.WorksheetFunction.Transpose(ws.Range("IV2:IV" & Rows.Count).SpecialCells(xlCellTypeConstants))
ArrayOfUniqueValues = Application.WorksheetFunction.Transpose(ws.Range("UniqueValues").EntireColumn.SpecialCells(xlCellTypeConstants))


'Delete the temporary values
ws.Range("UniqueValues").EntireColumn.Clear


'Loop through our array of unique field values, copy paste into new workbooks and save
For ArrayItem = 1 To UBound(ArrayOfUniqueValues)
    ws.ListObjects("Data").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)
    ws.Range("Data[#All]").SpecialCells(xlCellTypeVisible).Copy
    Workbooks.Add
    Range("A1").PasteSpecial xlPasteAll
    ActiveWorkbook.SaveAs SavePath & ArrayOfUniqueValues(ArrayItem) & Format(Now(), " YYYY-MM-DD hhmmss") & ".xlsx", 51
    ActiveWorkbook.Close False
    ws.ListObjects("Data").Range.AutoFilter Field:=ColumnHeadingInt
Next ArrayItem


ws.AutoFilterMode = False
MsgBox "Finished exporting!"
Application.ScreenUpdating = True
    
End Sub

enclosed raw and code file for your referne.

 

[Hudson Andrew]

Hi all, please ignore this thread , reached out to VB express forum ..

http://www.vbaexpress.com/forum/sho...ted-columns(not-all-rows)&p=382961#post382961

 

[Fluff]

How about

Sub Splitdata()
   Dim Pth As String
   Dim Cl As Range
   Dim ws As Worksheet
   Dim Col As Long
   
   Application.ScreenUpdating = False
   Set ws = Sheets("Data")
   Pth = Sheets("Control").Range("FolderPath")
   Col = Application.Match(Range("ExportCriteria").Value, Range("Data[#Headers]"), 0)
   
   ws.Range("B:B,D:E,I:I").EntireColumn.Hidden = True
   With CreateObject("scripting.dictionary")
      For Each Cl In ws.Range(ws.Cells(2, Col), ws.Cells(Rows.Count, Col).End(xlUp))
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, Nothing
            ws.ListObjects("Data").Range.AutoFilter Col, Cl.Value
            Workbooks.Add
            ws.Range("Data[#All]").SpecialCells(xlCellTypeVisible).Copy Range("a1")
            ActiveWorkbook.SaveAs Pth & Cl.Value & format(Now(), " YYYY-MM-DD hhmmss") & ".xlsx", 51
            ActiveWorkbook.Close False
         End If
      Next Cl
   End With
   ws.Cells.EntireColumn.Hidden = False
   ws.ShowAllData
End Sub

 

[Hudson Andrew]

Hi Friend,

This is brilliantly working and thank you so much , can you make this little dynamic by naming sheet name to workbook name and with out time stamp(just name and date)?.

Thanks for your help again.

 

[Fluff]

Add the part in blue

Workbooks.Add
[COLOR=#0000ff]ActiveSheet.Name = cl.Value & format(Date, " yyyy-mm-dd")[/COLOR]
ws.Range("Data[#All]").SpecialCells(xlCellTypeVisible).Copy Range("a1")

 

[Hudson Andrew]

Hi Friend .. this is awesome!! you must be crazy coder , this is working like charm !!! thanks for you help .

 

[Fluff]

Glad to help & thanks for the feedback

 

[Hudson Andrew]

Hi Friend one last request , will you be able to add this to my macro ?.

and the request is when i export the data to work books , can we add auto sum to the column "E" ?.( i .e "Price")

can this be do able ?.

 

[Fluff]

How about

            ws.Range("Data[#All]").SpecialCells(xlCellTypeVisible).Copy Range("a1")
            [COLOR=#0000ff]Range("E" & Rows.Count).End(xlUp).Offset(1).FormulaR1C1 = "=sum(r2c:r[-1]c)"[/COLOR]
            ActiveWorkbook.SaveAs Pth & Cl.Value & format(Now(), " YYYY-MM-DD hhmmss") & ".xlsx", 51

 

[Hudson Andrew]

Wow ! it really worked again like charm !!! thanks a lot for your help .