Sub MjozaWorkbookToWorkbooks() ' http://www.mrexcel.com/forum/excel-questions/899597-visual-basic-applications-loop-through-sheet-copy-contents-new-workbook.html 'http://www.excelforum.com/excel-programming-vba-macros/1101975-copy-the-data-from-master-file-and-paste-into-individual-excel-file-as-per-criteria.html
'ActiveWorkbook.Save
Application.ScreenUpdating = False 'This is not too important but can speed things up a bit by disabling the updating of the screen which otherwise frequently happens
On Error GoTo TheEnd 'In the case of an Error goto a section of code at the end of the program
Rem 1) Initial sheet info, Importantly Copying entire data from Sheet1 to an Array.
'Dim vTemp As Variant 'Temporary variable used in debugging
Dim wsMain As Worksheet, wbMain As Workbook 'Give Abbreviation Methods, Properties of Object Worksheet, Workbook through .dot
Set wbMain = ThisWorkbook: Set wsMain = wbMain.Worksheets("Sheet1") 'This code is in here, This Workbook
Dim rm As Long, cm As Long, lmr As Long, lmc As Long 'Variable for Rows, Columns, last Row last Column of Main sheet. Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, Integers (Short) need converted internally anyways, so a Long is actually faster.
Dim vLkUpc As Long: Let vLkUpc = 1 'set column number 'Column where search criteria for filtering is. '
Let lmc = wsMain.Cells(1, Columns.Count).End(xlToLeft).Column 'For this sheet the Range Object last cell in Header row, has the End porperty (argument XL to the left) applied returning the first Range object ( cell ) seen "looking" to the left. This further has the Column property applied which returns the column indicie for that cell
Let lmr = wsMain.Cells(Rows.Count, vLkUpc).End(xlUp).Row 'The Range Object ( cell ) that is the last cell in the column of interest has the property .End ( argument Xl up ) applied to it. This returns a new range ( cell ) which is that of the first Range ( cell ) with something in it "looking up" the XL spreadsheet from the last cell. Then the .Row Property is applied to return a long number equal to the row number of that cell. ( +1 would give the next free cell )
Dim rngDataIn As Range: Set rngDataIn = wsMain.Range("A2", wsMain.Cells(lmr, lmc)) 'This is our full Master data range
Dim arrin() As Variant: Let arrin() = rngDataIn.Value 'Allowed VBA One Liner - An Array of variants may be set to a collection of Range values. The Range object works as to return a collection of (Variants initially) of various types. So Initially must see an Array of Variant types for compatability
Rem 2) If necessary, a Folder "Completed" is created on the Desktop
Dim strFoldername As String, strDefpath As String 'String variables for the relavent parts of Folder Path
Dim objWSHShell As Object 'I use late binding below for sharing so as not to hve to --Tools --References --Scroll down and tick Microsoft Scripting Runtime library
Set objWSHShell = CreateObject("WScript.Shell") 'Creat a specific instance of WshShell is an Object that enables you to query and interact with various aspects of the Windows User Interface.
Dim GetDesktop As String: Let GetDesktop = objWSHShell.SpecialFolders("Desktop") 'This property of the WshShell gives the string path to the desktop
Let strDefpath = GetDesktop & "\" 'Default Path as That of where this code is
Let strFoldername = "Completed"
If Len(Dir("" & (strDefpath & strFoldername) & "", vbDirectory)) = 0 Then 'If the directory does not exist then...
MkDir (strDefpath & strFoldername) '...make it
Else 'The Directory ( Folder ) is presumably already there so do not make it again! Redundant code
End If
Rem 3) data in Look Up Column is considered and eunique Array ( eunuch() ) produced from that
Dim vLkUp() As Variant 'Dynamic one dimensional array for LookUpColumn
Let vLkUp() = Application.WorksheetFunction.Index(arrin(), 0, vLkUpc) 'Returns format type (1,1) (2,1) (3,1) (4,1)... >> Index Function with second argument ("row" co - ordinate) set to 0 will return the entire "column" given by third argument ( "column" - co ordinate ), applied to the first argument which is the grid, ( Array , Row_Number, Column_Number) http://www.excelforum.com/excel-new-users-basics/1080634-vba-1-dimensional-horizontal-and-vertical-array-conventions-ha-1-2-3-4-a.html https://usefulgyaan.wordpress.com/2013/06/12/vba-trick-of-the-week-slicing-an-array-without-loop-application-index/
Dim Eunuch() As String 'Array used for unique LookUpColumn values to be used as both Workbook Names and Search Criteria
ReDim Eunuch(1 To 1) 'We need to size it initially, but it must be a dynamic Array to allow us to increase it's size, hence not done by Dim(1 to 1) which would make it a non dynamic Array
Let Eunuch(1) = "Uniques" 'We do not use the first element of the Array, so just for fun put a Title in it
For rm = 1 To UBound(vLkUp(), 1) Step 1 'for each "row" in the Look Up Column ( we want to look at the values there )
If IsError(Application.Match(vLkUp(rm, 1), Eunuch(), 0)) Then 'Match would error if the Unique value was not in the Array for those unique values, in which case ...
ReDim Preserve Eunuch(1 To UBound(Eunuch()) + 1): Let Eunuch(UBound(Eunuch())) = vLkUp(rm, 1) '.. if not there then put it in!
Else: End If 'case a unique value already there for this "row"
Next rm
Rem 4) Main Outer loop for going through Input Array and copying data to workbooks ( Workbooks are creatde inf they do not exist, based on the unique search criteria
Dim Ceunt As Long: Let Ceunt = 0 'Loop Bound variable Count for "vertical" workbooks
Dim ws As Worksheet 'Temporary Worksheet variable for use when adressing File sheets through an inner loop
Dim rngExData As Range 'Temporary range object variable for use when addressing existing data range in an existing file
Dim clms() As Variant 'Array fo Indicies are obtained for the "columns" required in each "vertical" workbook is done just outside the loop as they are the same for all "Verticals". Variant type required to satisfy the type returned by the Evaluate method below
Let clms() = Evaluate("column(A:" & Left(Replace(Cells(1, UBound(arrin(), 2)).Address, "$", "", , 1), (InStr(Replace(Cells(1, UBound(arrin(), 2)).Address, "$", "", , 1), "$") - 1)) & ")") 'Not as complicated as it looks! - The messy bit just gets the Letter part out of the last cell Address. Then the worksheet Function Columns is used: Returns a 1 D "quasi" horizontal array of size _: to :_ In that array are the number _: to :_ . This "quasi horizontal" Array we require for out "magic" code line
For Ceunt = 2 To UBound(Eunuch()) 'we consider all th relavent unique "Verticals"==========MAIN LOOP=======
'4a) Indicies are obtained for the "rows" required in each "vertical" workbook
Dim rwsT() As Long: ReDim rwsT(1 To 1) 'Temporary Array for the indicies of required "rows"
For rm = 1 To UBound(vLkUp(), 1) Step 1 'for each "row" in the Look Up Column ( we want to look at the values there )
If Eunuch(Ceunt) = vLkUp(rm, 1) Then 'this would be the case of a "row" inidie we want
ReDim Preserve rwsT(1 To UBound(rwsT()) + 1): Let rwsT(UBound(rwsT())) = rm 'required indicie is put in the next "along" space in the Temporary 1 D Array
Else: End If '
Next rm
Dim rws() As Long: ReDim rws(1 To UBound(rwsT()) - 1, 1 To 1) 'Our Indicie Array, rws(), will be 1 less than the rwsT as rwsT(1) was not used and is not needed
For rm = 2 To UBound(rwsT()) 'for all the indicies in the Tempory Array..
Let rws((rm - 1), 1) = rwsT(rm) '..put in the indicie
Next rm
'4b) An Output Array for the the Workbook of this loop
Dim arrOut() As Variant: Let arrOut() = Application.Index(arrin(), rws(), clms()) 'This "magic" I still do not understand http://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html
Rem 5)'Produce Output Filees if necerssary and Paste Data
'wbMain.Save 'Just in case anything goes wrong after the next line which temporarily sremoves all Input Data
rngDataIn.ClearContents 'Full data is removed temporarily to prevent copying lots of data unecerssary when usin .Copy "One Liner to produce new "Vertical" File
Dim strMyDrive As String: Let strMyDrive = Left(strDefpath, 2) ', the drive ( C: E: etc )
ChDrive (strMyDrive): ChDir (strDefpath & strFoldername) 'Changing the Drive and Directory may be needed for check of Filename to work
Dim strFilename As String: Let strFilename = Eunuch(Ceunt) & " Monthly Data.xlsx" 'New Montly Filename given as that for the considered Unique Look Up Croteria in this Loop
Dim strFullPathname As String: Let strFullPathname = strDefpath & strFoldername & Application.PathSeparator & strFilename
If Dir(strFullPathname) <> "" Then 'case File exists 'Dir(CurDir & Application.PathSeparator & strFoldername) <> "" Then
Workbooks.Open FileName:=strFullPathname: ActiveWorkbook.Activate 'Open existing File and Activate it 'MsgBox "File is present"
Set rngExData = ActiveWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion 'CurrentRegion Property acting on a Range Object returns a new range of that in a "box2 encompassing all cells "connected" to The original range object
With rngExData
Set rngExData = .Offset(1, 0).Resize(.Rows.Count - .Row + 1 - 1, .Columns.Count - .Column - 1) 'the Offset Property returned a Range Object shifted 1 row down, and the resize property further retuned a range object of one row smaller, so as not to remove haedings
rngExData.ClearContents 'Clear data ready for new data' cannot use .Clear here as that will work on the original defined With rngExData
End With 'rngExData
Else 'Add Workbook 'Workbooks.Add:ActiveWorkbook.SaveAs Filename:=strFullPathname ', FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'5b All wanted sheets are copied in one go.
Dim Flag As Boolean: Let Flag = True 'Flag for first time around, whether to replace or add to selection
For Each ws In ThisWorkbook.Worksheets 'Going through all worksheets
If ws.Name = "Sheet1" Or ws.Name = "AnyOtherToCopy" Or ws.Name = "SpareSheet" Then 'Any Sheets to be considered by the following code lines should be written in here
ws.Select Replace:=Flag: Let Flag = False 'Select with argument False results in last selection remaing as part of the selection, so we effectively select all sheets we want at once.
Else: End If 'Case sheet not to be copied. Do nothing. redundant Code
Next ws
ActiveWindow.SelectedSheets.Copy 'VBA works such that applying .Copy to a sheet or, as here, sheets results in a copy of ttis workbook coming up in a window with the next avauilable default name. Fro now on we can refferenc this as the Active Workbook
ActiveSheet.Select Replace:=False 'Doesn't appear necerssary, but WTF, probably good practice.
End If
'5c)The filtered Data from Sheet1 in the Master File is placed in Sheet1 of Workbook in this file
With ActiveWorkbook 'The master sheet below must be by its name referrenced and not confused with that in the Master File, wsMain
If UBound(rws(), 1) > 1 Then 'Case more than one row with a Unique Look Up criteria relulting in arrOut being 2 Dimensional
.Worksheets("Sheet1").Range("A2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut() 'A nice "One" liner - Resize selected cell to size of output Array and then the allowed VBA assignment of a collection of values to a Spreadsheet range
Else 'Case only one Row found , arrOut() becomes a 1 dimensional Array,
.Worksheets("Sheet1").Range("A2").Resize(, UBound(arrOut())).Value = arrOut()
End If
Application.DisplayAlerts = False: .SaveAs FileName:=strFullPathname: Application.DisplayAlerts = True 'We turn off being alerted ( in this case that we will lose our macros for a .xlsx save): save the file : Switch the Alert object back on
.Close (1)
End With 'ActiveWorkbook
rngDataIn.Value = arrin() 'Put back in data in Master sheet
Next Ceunt 'Main loop for all Worksheets===============================================END MAIN LOOP======
TheEnd: 'Put all things here which shouls be done even in the case of an error.
Application.ScreenUpdating = True 'If this is not done the screen may be "dead" after the code finishes
Application.DisplayAlerts = True
Set objWSHShell = Nothing 'May not be necessary, but good practice
End Sub 'MjozaWorkbookToWorkbooks()
Other things don't 
