Home

Exporting information from excel document based on Location

%3CLINGO-SUB%20id%3D%22lingo-sub-1187672%22%20slang%3D%22en-US%22%3EExporting%20information%20from%20excel%20document%20based%20on%20Location%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-1187672%22%20slang%3D%22en-US%22%3E%3CP%3EI%20have%20several%20documents%20that%20need%20sorting%20to%20separate%20different%20documents%20based%20on%20certain%20criteria%20(like%20Location%20or%20Name).%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EI%20did%20find%20script%20already%2C%20but%20I%20have%20hard%20time%20to%20make%20it%20work%20independently%20on%20different%20documents.%20Although%20I%20kinda%20understand%20what%20the%20code%20does%2C%20I%20dont%20know%20how%20to%20successfully%20modify%20it%20for%20my%20needs.%20I%20also%20have%20hard%20time%20to%20understand%20from%20where%20different%20values%20or%20variables%20come%20from%20or%20how%20to%20set%20my%20own%20variables%20and%20place%20them%20inside%20the%20code...%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EThe%20script%20only%20works%20in%20that%20example%20file%2C%20but%20I%20cannot%20make%20it%20stand-alone.%20And%20what%20I%20mean%20by%20that%2C%20is%20I'd%20like%20to%20copy%2Bpaste%20the%20code%20into%20new%20Macro%20and%20then%20run%20it.%20Not%20to%20include%20it%20inside%20the%20document%20itself.%20Buttons%20etc%2C%20like%20in%20the%20example%20file%20had.%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EIn%20my%20case%2C%20I%20receive%20Excel-files%2C%20that%20contain%20information%20about%20different%20offices%20and%20their%20monthly%20work%20orders%20and%20so%20on.%20I'd%20like%20to%20have%20every%20shop%20to%20be%20sorted%20and%20automaticly%20copied%20to%20their%20own%20files%20so%20every%20shops%20own%20information%20would%20be%20send%20to%20them%20only.%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EWhat%20I%20did%20manage%20to%20do%20is%20force%20output%20folder%20and%20set%20proper%20Cell%20from%20which%20the%20unique%20information%20is%20gathered.%20But%20%22Range(%22Data%5B%23Headers%5D%22)%2C%200)%22%20gives%20error%20%22Method%20range%20of%20object%20-%20'Global'%20failed%22%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EI%20also%20tried%20to%20make%20simple%20variables%20at%20the%20beginning%20of%20the%20code%2C%20so%20it%20would%20be%20simpler%20to%20set%20output%20folders%20and%20criteria%20cell%2C%20in%20case%20the%20Excel%20format%20might%20change%20someday%3C%2FP%3E%3CPRE%3EOption%20Explicit%3CBR%20%2F%3E%3CBR%20%2F%3ESub%20ExportData()%3CBR%20%2F%3E%3CBR%20%2F%3E'Declare%20variables%3CBR%20%2F%3EDim%20ArrayItem%20As%20Long%3CBR%20%2F%3EDim%20ws%20As%20Worksheet%3CBR%20%2F%3EDim%20ArrayOfUniqueValues%20As%20Variant%3CBR%20%2F%3EDim%20SavePath%20As%20String%3CBR%20%2F%3EDim%20ColumnHeadingInt%20As%20Long%3CBR%20%2F%3EDim%20ColumnHeadingStr%20As%20String%3CBR%20%2F%3EDim%20rng%20As%20Range%3CBR%20%2F%3E%3CBR%20%2F%3E'Set%20the%20worksheet%20to%3CBR%20%2F%3ESet%20ws%20%3D%20Sheets(%22Data%22)%3CBR%20%2F%3E%3CBR%20%2F%3E'Set%20the%20save%20path%20for%20the%20files%20created%3CBR%20%2F%3ESavePath%20%3D%20%22D%3A%5CHome%5CProjects%5Cexcel%5Cputput2%5C%22%3CBR%20%2F%3E%3CBR%20%2F%3E'Set%20variables%20for%20the%20column%20we%20want%20to%20separate%20data%20based%20on%3CBR%20%2F%3EColumnHeadingInt%20%3D%20WorksheetFunction.Match(Range(%22B1%22).Value%2C%20Range(%22Data%5B%23Headers%5D%22)%2C%200)%3CBR%20%2F%3EColumnHeadingStr%20%3D%20%22Data%5B%5B%23All%5D%2C%5B%22%20%26amp%3B%20Range(%22B1%22).Value%20%26amp%3B%20%22%5D%5D%22%3CBR%20%2F%3E%3CBR%20%2F%3E'Turn%20off%20screen%20updating%20to%20save%20runtime%3CBR%20%2F%3EApplication.ScreenUpdating%20%3D%20False%3CBR%20%2F%3E%3CBR%20%2F%3E'Create%20a%20temporary%20list%20of%20unique%20values%20from%20the%20column%20we%20want%20to%3CBR%20%2F%3E'separate%20our%20data%20based%20on%3CBR%20%2F%3ERange(ColumnHeadingStr%20%26amp%3B%20%22%22).AdvancedFilter%20Action%3A%3DxlFilterCopy%2C%20_%3CBR%20%2F%3ECopyToRange%3A%3DRange(%22UniqueValues%22)%2C%20Unique%3A%3DTrue%3CBR%20%2F%3E%3CBR%20%2F%3E'Sort%20our%20temporary%20list%20of%20unique%20values%3CBR%20%2F%3Ews.Range(%22UniqueValues%22).EntireColumn.Sort%20Key1%3A%3Dws.Range(%22UniqueValues%22).Offset(1%2C%200)%2C%20_%3CBR%20%2F%3EOrder1%3A%3DxlAscending%2C%20Header%3A%3DxlYes%2C%20OrderCustom%3A%3D1%2C%20MatchCase%3A%3DFalse%2C%20_%3CBR%20%2F%3EOrientation%3A%3DxlTopToBottom%2C%20DataOption1%3A%3DxlSortNormal%3CBR%20%2F%3E%3CBR%20%2F%3E'Add%20unique%20field%20values%20into%20an%20array%3CBR%20%2F%3E'ArrayOfUniqueValues%20%3D%20Application.WorksheetFunction.Transpose(ws.Range(%22IV2%3AIV%22%20%26amp%3B%20Rows.Count).SpecialCells(xlCellTypeConstants))%3CBR%20%2F%3EArrayOfUniqueValues%20%3D%20Application.WorksheetFunction.Transpose(ws.Range(%22UniqueValues%22).EntireColumn.SpecialCells(xlCellTypeConstants))%3CBR%20%2F%3E%3CBR%20%2F%3E'Delete%20the%20temporary%20values%3CBR%20%2F%3Ews.Range(%22UniqueValues%22).EntireColumn.Clear%3CBR%20%2F%3E%3CBR%20%2F%3E'Loop%20through%20our%20array%20of%20unique%20field%20values%2C%20copy%20paste%20into%20new%20workbooks%20and%20save%3CBR%20%2F%3EFor%20ArrayItem%20%3D%201%20To%20UBound(ArrayOfUniqueValues)%3CBR%20%2F%3Ews.ListObjects(%22Data%22).Range.AutoFilter%20Field%3A%3DColumnHeadingInt%2C%20Criteria1%3A%3DArrayOfUniqueValues(ArrayItem)%3CBR%20%2F%3Ews.Range(%22Data%5B%23All%5D%22).SpecialCells(xlCellTypeVisible).Copy%3CBR%20%2F%3EWorkbooks.Add%3CBR%20%2F%3ERange(%22A1%22).PasteSpecial%20xlPasteAll%3CBR%20%2F%3EActiveWorkbook.SaveAs%20SavePath%20%26amp%3B%20ArrayOfUniqueValues(ArrayItem)%20%26amp%3B%20Format(Now()%2C%20%22%20YYYY-MM-DD%20hhmmss%22)%20%26amp%3B%20%22.xlsx%22%2C%2051%3CBR%20%2F%3EActiveWorkbook.Close%20False%3CBR%20%2F%3Ews.ListObjects(%22Data%22).Range.AutoFilter%20Field%3A%3DColumnHeadingInt%3CBR%20%2F%3ENext%20ArrayItem%3CBR%20%2F%3E%3CBR%20%2F%3Ews.AutoFilterMode%20%3D%20False%3CBR%20%2F%3EMsgBox%20%22Finished%20exporting!%22%3CBR%20%2F%3EApplication.ScreenUpdating%20%3D%20True%3CBR%20%2F%3E%3CBR%20%2F%3EEnd%20Sub%3C%2FPRE%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-LABS%20id%3D%22lingo-labs-1187672%22%20slang%3D%22en-US%22%3E%3CLINGO-LABEL%3EExcel%3C%2FLINGO-LABEL%3E%3CLINGO-LABEL%3EMacros%20and%20VBA%3C%2FLINGO-LABEL%3E%3C%2FLINGO-LABS%3E
Highlighted
Occasional Visitor

I have several documents that need sorting to separate different documents based on certain criteria (like Location or Name).

 

I did find script already, but I have hard time to make it work independently on different documents. Although I kinda understand what the code does, I dont know how to successfully modify it for my needs. I also have hard time to understand from where different values or variables come from or how to set my own variables and place them inside the code...

 

The script only works in that example file, but I cannot make it stand-alone. And what I mean by that, is I'd like to copy+paste the code into new Macro and then run it. Not to include it inside the document itself. Buttons etc, like in the example file had.

 

In my case, I receive Excel-files, that contain information about different offices and their monthly work orders and so on. I'd like to have every shop to be sorted and automaticly copied to their own files so every shops own information would be send to them only.

 

What I did manage to do is force output folder and set proper Cell from which the unique information is gathered. But "Range("Data[#Headers]"), 0)" gives error "Method range of object - 'Global' failed"

 

I also tried to make simple variables at the beginning of the code, so it would be simpler to set output folders and criteria cell, in case the Excel format might change someday

Option Explicit

Sub ExportData()

'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 = "D:\Home\Projects\excel\putput2\"

'Set variables for the column we want to separate data based on
ColumnHeadingInt = WorksheetFunction.Match(Range("B1").Value, Range("Data[#Headers]"), 0)
ColumnHeadingStr = "Data[[#All],[" & Range("B1").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(1, 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

 

Related Conversations
Multiple drop down list
sure19 in Excel on
1 Replies
Insert empty row between last names
LMesi1110 in Excel on
0 Replies
Office 365 Excel Freezes
jmanderson42 in Excel on
0 Replies
Need help combining columns to export email group to outlook
FlaTchr in Excel on
4 Replies