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

**DocAElstein** · 01-24-2021, 07:33 PM

Macro for last two posts

Code:

' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _  First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _  Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _  I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()
Dim a(), arrOut__(), Cls(), Cls_v() As String, Rws(), asum
    Dim Rng As Range, Rng_v As Range, Rng_vVls() As Variant, cel As Range
    Dim i As Integer, ii As Integer
Dim Pth As String: Let Pth = ThisWorkbook.Path & Application.PathSeparator '   Const pth = "c:\Users\User\Downloads\"      '<---- use own path
Const wnm = "Workbook2_1.xlsx"                   'your workbook name
Rem 1 the main data range from source
    With ThisWorkbook.Sheets("Sheet1")
     Set Rng = Range("a1:aH" & 36 & "")   '  Range("a1:ag" & 36 & "")   '  hard coded for testing         .UsedRange.Rows.Count)
     Let a() = Rng.Value           '    The main source data range
     Let Cls() = Rng.Rows(1).Value '    The header row
     ReDim Rws(1 To UBound(a))     '    The row indicies of the rows we are intersted in from the filtered range ##### this will likely be much too big at this stage but we will correct that later
    End With
Rem 2 building a single column array for the summed colums
    Set Rng_v = Rng.Columns(2).SpecialCells(xlCellTypeVisible)  '  for  maras  datas this will be 11 data rows and the header 0 12 rows in total
                      'Rng_vVls() = Rng_v.Value2  '  This is for my testing only - this will give me just first area
    If Rng_v.Count > 1 Then
        ReDim asum(1 To Rng_v.Count) '  1 D array to hold sum values - I wanted to sum from column O to column Z and transfer those sum to destination at column I
        For Each cel In Rng_v
            If cel.Row > 1 And cel.Value <> "" Then
             Let ii = ii + 1
             Let asum(ii) = Evaluate("sum(o" & cel.Row & ": z" & cel.Row & ")") ' Evaluate Range way to sum a range
             Let i = i + 1
             Let Rws(i) = cel.Row
            End If
        Next
        If ii > 0 Then ReDim Preserve asum(1 To ii) ' Our array is one element too big with an empty element, so thhis takes off that extra unwanted element
        If i > 0 Then ReDim Preserve Rws(1 To i)    ' Our array is much too big so this makes it the correct size ####
    Else ' case no data rows, only a header row
    End If
    If Rng_v.Count = 1 Or i = 0 Then
        MsgBox "No rows to transfer."
        Exit Sub
    End If
Rem 2
    Workbooks.Open Filename:=Pth & wnm
'2a) Gets the column indicies of the columns wanted from the data worksheet
    With ActiveWorkbook
        With .Sheets("Sheet1")
        Dim vTemp As Variant
         vTemp = Application.Match(.UsedRange.Rows(1), Rng.Rows(1), 0) '  This gives a 1 D array and each element has either the position of the header in the destination workbook, or an error if it did not find it
         '  { 2 ,  error  , 3  , 4 ,  5 ,  11  , error  ,  27 ,  28 ,  29  , 30 ,  31 ,  32 ,  33  }
         ' So the above line tells us where there is an error in a match with the header names
         Let vTemp = Application.IfError(vTemp, "x") ' Instead of the vbError , a text of  "x"  is put into the array
         '  { 2 ,  x   , 3  , 4 ,  5 ,  11  , x  ,  27 ,  28 ,  29  , 30 ,  31 ,  32 ,  33  }
         Let vTemp = Filter(vTemp, "x", False, 0) ' take out the  "x"s
         '  { 2 ,  x   , 3  , 4 ,  5 ,  11  , x  ,  27 ,  28 ,  29  , 30 ,  31 ,  32 ,  33  }
         Let Cls_v() = Filter(Application.IfError(Application.Match(.UsedRange.Rows(1), Rng.Rows(1), 0), "x"), "x", False, 0)
         '  { 2   , 3  , 4 ,  5 ,  11  ,   27 ,  28 ,  29  , 30 ,  31 ,  32 ,  33  }
'2b)    Typical arrOut()=AppIndex(arrIn(), Rws(), Clms())
         Let arrOut__() = Application.Index(a(), Application.Transpose(Rws()), Cls_v())  '   Typical arrOut()=AppIndex(arrIn(), Rws(), Clms())
'2c)    arrOut__() is not quite the final array we want. Its condensed missing out a couple of empty columns, so in code section '2b) we pick out the sections we want and put them in the appropriate place.
            With .Range("B2")   '    UsedRange.Offset(1)
                '.ClearContents
                .Resize(UBound(Rws()), 1) = Application.Index(arrOut__(), Evaluate("row(1:" & UBound(Rws()) & ")"), 1) ' column B in output
                .Offset(, 2).Cells(1).Resize(UBound(Rws()), 4).Value = Application.Index(arrOut__(), (Evaluate("row(1:" & UBound(Rws()) & ")")), Application.Transpose(Evaluate("row(2:" & UBound(arrOut__(), 2) & ")")))  ' column D to G
                .Offset(, 7).Cells(1).Resize(UBound(Rws()), UBound(arrOut__(), 2) - 5).Value = Application.Index(arrOut__(), Evaluate("row(1:" & UBound(Rws()) & ")"), Application.Transpose(Evaluate("row(6:" & UBound(arrOut__(), 2) & ")"))) ' column  I to O
                .Offset(, 6).Cells(1).Resize(UBound(Rws())) = Application.Transpose(asum) ' sums column H
            End With
        End With
        '.Save
    End With
'    Set Rng = Nothing
'    Set Rng_v = Nothing
End Sub