Code:
Sub Ha2a() ' https://eileenslounge.com/viewtopic.php?f=27&t=35006
Rem 1 worksheets data info
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1) ' First worksheet counting tabs from the left
Dim Lr As Long: Let Lr = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row ' Make Lr Dynamic : https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=11467&viewfull=1#post11467
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr + 1 & "").Value2 ' The only data needed to ba considered is column A. The "magic code line" will be used to get all our results in one go I need +1 to use an empty line in determining when the last name in the list has something different after it ##
Rem 2 Outer loop Do ing While data is still there in column A
Dim CntIn As Long: Let CntIn = 1 ' This will be for counting as We go down rows in column A
Do ' ========================================================== Main Outel loop for unique name section==
Rem 3 Inner Loop for a section of names ' ---------------------------------------------------------------
Dim strRws As String: Let strRws = "1" ' We are building a string of our required row indicia for a unique name. The first row , the header, will always be needed
Do
'3a) get the row indicies for this section
Let CntIn = CntIn + 1
Let strRws = strRws & " " & CntIn
Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1) ' this means we are not yet at the end of a section ---
'3b) start doing stuff for each unique name
'3b(i) The workbook with unique name
Workbooks.Add
Dim WbNme As String: Let WbNme = arrA(CntIn, 1) & ".xlsx" ' The current last unique name will be the new Workbook name
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & WbNme '
Dim Ws As Worksheet: Set Ws = Workbooks(WbNme).Worksheets.Item(1)
'3b(ii) The "vertical" array of row indicies required for "magic code line"
Dim Rws() As String: Let Rws() = Split(strRws, " ", -1, vbBinaryCompare) ' I can make a 1 Dimesional pseudo "horizontal" array easilly, from which the "horizontal array, RwsT() can be made
Dim RwsT() As String ' I must make this a dynamic array, even though I know the dimensions, because the Dim statement will only take hard coded numbers, wheras the ReDim method below allows us to make the sizing dynamic based on the size of Rws()
ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1) ' The +1 comes in because the Split function returns a 1D array starting at indicia 0
Dim Cnt As Long
For Cnt = 1 To UBound(Rws()) + 1
Let RwsT(Cnt, 1) = Rws(Cnt - 1)
Next Cnt
'3b(iii) The "magic code line"
Dim Clms() As Variant: Let Clms() = Evaluate("=COLUMN(A:C)") ' ** CHANGE TO SUIT ** This is currently for columns A B C 1 2 3 For non consequtive columns you can use like Array("1", "3", "26") - that last example gives in the new range just columns A C Z from the original worksheet
Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Clms()) ' The magic code line --- ' "Magic code line" http://www.eileenslounge.com/viewtopic.php?p=265384#p265384 http://www.eileenslounge.com/viewtopic.php?p=265384&sid=39b6d764de41f462fe66f62816e5d789#p265384 See also https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172 , http://www.excelfox.com/forum/showthread.php/2145-Excel-VBA-Interception-and-Implicit-Intersection-and-VLookUp for full explanation
'3b(iv) Output to first worksheet in workbook and close and save it
Let Ws.Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() ' We can paste out an array of values in one go to a spreadsheet range. Here A1 is taken as top right which is then resized to the size of the field of data values in arrOut()
Workbooks(WbNme).Close Savechanges:=True
'3b(v) Some tidying up before we possibly go to the next unique name
Let strRws = "1" ' we must reset this, or else we will still have row indicies in it from the last unique name
Loop While CntIn < Lr
' =======================================================================================================
End Sub
' Simplified version
Sub Ha2a_()
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1)
Dim Lr As Long: Let Lr = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr + 1 & "").Value2
Dim CntIn As Long: Let CntIn = 1
Do
Dim strRws As String: Let strRws = "1"
Do
Let CntIn = CntIn + 1
Let strRws = strRws & " " & CntIn
Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1)
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & arrA(CntIn, 1) & ".xlsx"
Dim Rws() As String: Let Rws() = Split(strRws)
Dim RwsT() As String
ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1)
Dim Cnt As Long
For Cnt = 1 To UBound(Rws()) + 1
Let RwsT(Cnt, 1) = Rws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Array(1, 2, 3))
Let Workbooks(arrA(CntIn, 1) & ".xlsx").Worksheets.Item(1).Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut()
Workbooks(arrA(CntIn, 1) & ".xlsx").Close Savechanges:=True
Let strRws = "1"
Loop While CntIn < Lr
End Sub
Reply With Quote
Bookmarks