Tests Copying, Pasting, API Cliipboard issues. and Rough notes on Advanced API stuff

**DocAElstein** · 07-24-2020, 03:12 PM

Full macro version for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=35006
solution post
https://eileenslounge.com/viewtopic....271960#p271960

Code:

Sub Ha2b()  '  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 LrM As Long: Let LrM = 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" & LrM + 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
Dim strTRw As Long: Let strTRw = 2  ' We are wanting to determine the start and stop row of a grouped names section. The first one will be at row 2
    
    Do ' ========================================================== Main Outel loop for unique name section==
    Rem 3 Inner Loop for a section of names ' ---------------------------------------------------------------
        Do
        '3a) get the row indicies for this section
         Let CntIn = CntIn + 1
        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 StpRw As Long: Let StpRw = CntIn ' this is the last row for a group of names
    Dim RwsT() As Variant ' I need Variant  because the   Evaluate(" ")  methond below returns its field of values in housed in  Variant  type elements
     Let RwsT() = Evaluate("=ROW(" & strTRw & ":" & StpRw & ")")
    '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()
     Let Ws.Range("A2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() ' I am missing the Header row so start at top left  A2  to leave space for the Header
     WsM.Range("A1:C1").Copy ' Header row
     Ws.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
     Workbooks(WbNme).Close Savechanges:=True
    '3b(v) Some tidying up before we possibly go to the next unique name
     Let strTRw = CntIn + 1 ' I assume the next row is  the next name
    Loop While CntIn < LrM
    ' =======================================================================================================


End Sub
' simplified version
Sub Ha2b_()
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1)
Dim LrM As Long: Let LrM = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & LrM + 1 & "").Value2
Dim CntIn As Long: Let CntIn = 1
Dim strTRw As Long: Let strTRw = 2
    Do
        Do
         Let CntIn = CntIn + 1
        Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1)
     Workbooks.Add
     ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & arrA(CntIn, 1) & ".xlsx"
    Dim Ws As Worksheet: Set Ws = Workbooks(arrA(CntIn, 1) & ".xlsx").Worksheets.Item(1)
    Dim StpRw As Long: Let StpRw = CntIn
    Dim RwsT() As Variant
     Let RwsT() = Evaluate("=ROW(" & strTRw & ":" & StpRw & ")")
    Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Array(1, 2, 3))
     Let Ws.Range("A2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut()
     WsM.Range("A1:C1").Copy
     Workbooks(arrA(CntIn, 1) & ".xlsx").Worksheets.Item(1).Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
     Workbooks(arrA(CntIn, 1) & ".xlsx").Close Savechanges:=True
     Let strTRw = CntIn + 1
    Loop While CntIn < LrM
End Sub