Code:
Sub DaDoRunRonDeDo2() ' 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
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr & "").Value2
Rem 2 obtain unique values from column A
' 2a) A single string containing the unique names
Dim Cnt As Long
For Cnt = 2 To Lr Step 1
Dim strUnics As String
If InStr(1, strUnics, arrA(Cnt, 1), vbBinaryCompare) = 0 Then
Let strUnics = strUnics & arrA(Cnt, 1) & " "
Else
' we already had that name in the string
End If
Next Cnt
Let strUnics = Left(strUnics, (Len(strUnics) - 1)) ' Take off last space
' 2b) A 1 dimansional array of the unique names
Dim arrUnics() As String: Let arrUnics() = Split(strUnics, " ", -1, vbBinaryCompare)
Rem 3 Do it for each unique name
Dim WbCnt As Long: Let WbCnt = UBound(arrUnics()) + 1 ' +1 is needed because Split function returns an array starting at indicia 0
For WbCnt = 1 To WbCnt ' Main outer Loop ========================================
' 3a) Get our indicies for the rows wanted of our current name
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
For Cnt = 2 To Lr Step 1
If arrA(Cnt, 1) = arrUnics(WbCnt - 1) Then
Let strRws = strRws & " " & Cnt
Else
' The name is not one of the current name being considered
End If
Next Cnt
'3b) start doing stuff for each unique name
'3b(i) The workbook with unique name
Workbooks.Add
Dim WbNme As String: Let WbNme = arrUnics(WbCnt - 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
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
Next WbCnt ' =====================================================================
End Sub
' simplified version
Sub DaDoRunRonDeDo2_()
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 & "").Value2
Dim Cnt As Long
For Cnt = 2 To Lr Step 1
Dim strUnics As String
If InStr(strUnics, arrA(Cnt, 1)) = 0 Then strUnics = strUnics & arrA(Cnt, 1) & " "
Next Cnt
Dim arrUnics() As String: Let arrUnics() = Split(Trim(strUnics))
Dim WbCnt As Long
For WbCnt = 1 To UBound(arrUnics()) + 1
Dim strRws As String: Let strRws = "1"
For Cnt = 2 To Lr Step 1
If arrA(Cnt, 1) = arrUnics(WbCnt - 1) Then strRws = strRws & " " & Cnt
Next Cnt
Workbooks.Add
Dim WbNme As String: Let WbNme = arrUnics(WbCnt - 1) & ".xlsx"
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & arrUnics(WbCnt - 1) & ".xlsx"
Dim Rws() As String: Let Rws() = Split(strRws, " ", -1, vbBinaryCompare)
Dim RwsT() As String
ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1)
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(arrUnics(WbCnt - 1) & ".xlsx").Worksheets.Item(1).Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut()
Workbooks(arrUnics(WbCnt - 1) & ".xlsx").Close Savechanges:=True
Let strRws = "1"
Next WbCnt
End Sub
Reply With Quote
Bookmarks