Appendix-Thread-Evaluate-Range-(-Codes-for-other-Threads-HTML-Tables-etc-)

post to use later

In support of this post



Before Source worksheet


_____ Workbook: Transfer data_marasAlan_1.xlsm ( Using Excel 2007 32 bit )

Row\Col	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH
1	Number	Unique ID	Name	Title	Platform	Filter					Salary				Add1	Add2	Add3	Add4	Add5	Add6	Add7	Add8	Add9	Add10	Add11	Add12	copy1	copy2	copy3	copy4	copy5	copy6	copy7	Total
4	3	3658	Lalu	Lead	C	Filter2					300				0	6	6	0	6	0	6	0	0	0	0	0	0	0	1	1	2	0		4
9	2	563	Vidu_xx	Manager	Java	Filter2					400				0	0	0	0	0	0	0	0	0	0	0	0	0	0	8	12	0	0	1	21
10	2	563	Vidu_max	Manager	Java	Filter2					425				0	0	0	0	0	0	0	0	0	0	0	0	0	0	8	12	0	0	2	22
12	2	563	Vidu	Manager	Java	Filter2					400				0	0	0	0	0	0	0	0	0	0	0	0	0	0	8	13	0	0		21
16	2	354	Sai	Operator	C++	Filter2					150				0	0	0	23	0	0	2	0	0	0	0	0	0	0	24	0	0	0		24
17	2	333	Fran	Operator	SQL	Filter2					150				0	0	1	0	0	0	0	0	0	0	0	1	0	0	0	0	0	0		0
18	3	239	Jack_max	Lead	SQL	Filter2					566				0	0	0	0	0	0	0	45	0	0	0	0	4	4	0	8	4	0		20
19	3	239	Jack	Lead	SQL	Filter2					300				0	0	0	0	0	0	0	46	0	0	0	0	4	4	4	8	4	0		24
23	4	222	Andy	Operator	Java	Filter2					150				0	0	0	0	0	0	0	0	0	0	0	0	0	4	0	0	14	8		26
24	1	123	Ram	Manager	Java	Filter2					400				0	0	3	0	0	0	0	0	0	55	0	0	12	0	0	0	0	3		15
36	1	26	Som	Operator	C	Filter2					150				0	0	2	0	7	0	0	0	0	0	0	333	0	0	4	0	6	0	22	32

Worksheet: Sheet1

In support of this post



Before destination worksheet


_____ Workbook: Workbook2_1.xlsx ( Using Excel 2007 32 bit )

Row\Col	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1		Unique ID		Name	Title	Platform	Salary	Sum	copy1	copy2	copy3	copy4	copy5	copy6	copy7
2

Worksheet: Sheet1


Destination After

_____ Workbook: Workbook2_1.xlsx ( Using Excel 2007 32 bit )

Row\Col	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	Unique ID		Name	Title	Platform	Salary	Sum	copy1	copy2	copy3	copy4	copy5	copy6	copy7
2	3658		Lalu	Lead	C	£300	24			1	1	2
3	563		Vidu_xx	Manager	Java	£400	0			8	12			1
4	563		Vidu_max	Manager	Java	£425	0			8	12			2
5	563		Vidu	Manager	Java	£400	0			8	13
6	354		Sai	Operator	C++	£150	25			24
7	333		Fran	Operator	SQL	£150	2
8	239		Jack_max	Lead	SQL	£566	45	4	4		8	4
9	239		Jack	Lead	SQL	£300	46	4	4	4	8	4
10	222		Andy	Operator	Java	£150	0		4			14	8
11	123		Ram	Manager	Java	£400	58	12					3
12	26		Som	Operator	C	£150	342			4		6		22

Worksheet: Sheet1

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


---

---

_._______________________________

Here is a before and after…
https://excelfox.com/forum/showthrea...ll=1#post15278
https://excelfox.com/forum/showthrea...ll=1#post15279

Macro
https://excelfox.com/forum/showthrea...ll=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

In support of this post


Source Workbook

_____ Workbook: Transfer data_marasAlan_2.xlsm ( Using Excel 2007 32 bit )

Row\Col	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI
1	Number	Unique ID	Name	Title	Platform	Filter					Salary				Add1	Add2	Add3	Add4	Add5	Add6	Add7	Add8	Add9	Add10	Add11	Add12	copy1	copy2	copy3	copy4	copy5	copy6	copy7
2	1	123	Ram	Manager	Java	Filter2					£400						3							55			12					3	222
9	1	26	Som	Operator	C	Filter2					£150																						1,013
10	2	354	Sai	Operator	C++	Filter2					£150							23			2								24				1,126
17	2	563	Vidu	Manager	Java	Filter2					£400																		8	12			147
18	3	239	Jack	Lead	SQL	Filter2					£300											45					4	4		8	4		149
19	4	222	Andy	Operator	Java	Filter2					£150																	4			14	8	151
24	2	333	Fran	Operator	SQL	Filter2					£150						1									1							161
25	3	3658	Lalu	Lead	C	Filter2					£300					6	6		6		6								1	1	2		163
30
31

Worksheet: Sheet1

In support of this post




Designation workbook before

_____ Workbook: Workbook2_2.xlsx ( Using Excel 2007 32 bit )

Row\Col	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1		Unique ID	Gap	Name	Title	Platform	Salary	Gap	Total	copy1	copy2	copy3	copy4	copy5	copy6	copy7
2

Worksheet: sheet1

Destination workbook after running macro Sub Transfer_marasAlan_2()

_____ Workbook: Workbook2_2.xlsx ( Using Excel 2007 32 bit )

Row\Col	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1	Unique ID	Gap	Name	Title	Platform	Salary	Gap	Total	copy1	copy2	copy3	copy4	copy5	copy6	copy7
2	123		Ram	Manager	Java	£400		58	12					3	222
3	26		Som	Operator	C	£150		0							1,013
4	354		Sai	Operator	C++	£150		25			24				1,126
5	563		Vidu	Manager	Java	£400		0			8	12			147
6	239		Jack	Lead	SQL	£300		45	4	4		8	4		149
7	222		Andy	Operator	Java	£150		0		4			14	8	151
8	333		Fran	Operator	SQL	£150		2							161
9	3658		Lalu	Lead	C	£300		24			1	1	2		163
10

Worksheet: sheet1

macro for last two posts

Code:

---

Option Explicit
Sub Transfer_marasAlan_2() '
Dim a(), Cls(), Cls_v() As String, Rws(), aSum(), arrOut__()
Dim Rng As Range, Rng_v As Range, Cel As Range, WbDest As Workbook
Dim i As Integer, ii As Integer
Dim Pth As String
 Let Pth = ThisWorkbook.Path & Application.PathSeparator '  Const Pth = "C:\Users\L026936\Desktop\Excel\"      '<---- use own path
Const wnm = "Workbook2_2.xlsx"              'your workbook name
    '    Application.ScreenUpdating = False
Rem 1 the main data range from source
    With ThisWorkbook.Sheets("Sheet1")
    Set Rng = .Range("a1:ag" & 25 & "")    '  Hardcoded for demonstration purposes      .UsedRange.Rows.Count)
    Let a() = Rng.Value                    '  main complete data range
    Let Cls() = Rng.Rows(1).Value          '  header row array
    ReDim Rws(1 To UBound(a))              '  This will be much too big initially - its the full all row size, but we will only want a reduced filtered number of rows - later #### this will be corrected
    End With
    Set Rng_v = Rng.Columns(2).SpecialCells(xlCellTypeVisible) ' this gets just the range we see, so will be likely a range of lots of areas
    If Rng_v.Count > 1 Then
Rem 2 building a single column array for the summed colums
 ReDim aSum(1 To Rng_v.Count)                ' this is "one row too big" **
        For Each Cel In Rng_v
            If Cel.Row > 1 And Cel.Value <> "" Then
            Let i = i + 1
            Let aSum(i) = Evaluate("sum('[Transfer data_marasAlan_2.xlsm]Sheet1'!o" & Cel.Row & ": '[Transfer data_marasAlan_2.xlsm]Sheet1'!z" & Cel.Row & ")")
            Let Rws(i) = Cel.Row
            End If
        Next
        If i > 0 Then
        ReDim Preserve aSum(1 To i)        ' **  this sets the correct size
        ReDim Preserve Rws(1 To i)          ' #### this sets just enought row size for our final output array
        Let aSum() = Application.Transpose(aSum())  ' we need a "virtical" "column" array
        Let Rws() = Application.Transpose(Rws())    ' we need a virtical array in the second argumant of the  Typical arrOut()=AppIndex(arrIn(), Rws(), Clms())  code line
        End If
    Else ' case only header range visible
    End If
    If Rng_v.Count = 1 Or i = 0 Then
        MsgBox "No rows to transfer."
        Exit Sub
    End If
    On Error Resume Next    '    https://eileenslounge.com/viewtopic.php?f=30&t=35861&start=20
    Set WbDest = Workbooks(wnm) ' will error if workbook is not yet open
        If Err.Number > 0 Then Workbooks.Open Filename:=Pth & wnm ' we test to see if we have an error and if we do themn we kknow to open the workbook
    On Error GoTo 0
    Set WbDest = ActiveWorkbook
'2a) Gets the column indicies of the columns wanted from the data worksheet
    With WbDest '  ActiveWorkbook
        With .Sheets("Sheet1")
        Dim vTemp As Variant ' just for demo purposes
        Let 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  ,  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 , x,  ,  27 ,  28 ,  29  , 30 ,  31 ,  32 ,  33  }
        Let vTemp = Filter(vTemp, "x", False, 0) ' take out the  "x"s
        '  { 2    , 3  , 4 ,  5 ,  11  ,  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(), Rws(), Cls_v())
 '2c)    arrOut__() is not quite the final array we want. Its condensed missing out a couple of empty columns, so in code section '2c) we pick out the sections we want and put them in the appropriate place. In addition we paste in the sum columns that we got in section Rem 2
            With Range("B2")  '    .UsedRange.Offset(1)
            .Resize(UBound(Rws), 1) = arrOut__()  '  arrOut__() is 8 columns, but this linw will just put the first column in
            Let Rws() = Evaluate("row(1:" & UBound(arrOut__()) & ")")  '  for convenience again we are using the variable  Rws()  for sequential rows for  our arrOut__()  as we want all rows in the order that they are there
            .Offset(, 2).Cells(1).Resize(UBound(arrOut__()), 4).Value = Application.Index(arrOut__(), Rws(), Array(2, 3, 4, 5))  '  columns D to G
            .Offset(, 8).Cells(1).Resize(UBound(Rws()), UBound(arrOut__(), 2) - 5).Value = Application.Index(arrOut__(), Rws(), Array(6, 7, 8, 9, 10, 11, 12))  '  columns J to P
            .Offset(, 7).Cells(1).Resize(UBound(Rws())) = aSum()  ' put the totals column in I
            End With
        End With
'        .Save
    End With
'    Set Rng = Nothing
'    Set Rng_v = Nothing
End Sub



---

_._______________________________

Here is a before and after…
https://excelfox.com/forum/showthrea...ll=1#post15276
https://excelfox.com/forum/showthrea...ll=1#post15273


Macro
https://excelfox.com/forum/showthrea...ll=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

In support of this post

Source Workbook

_____ Workbook: Transfer data_marasAlan_3.xlsm ( Using Excel 2007 32 bit )

Row\Col	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI
1	Number	Unique ID	Name	Title	Platform	Filter					Salary				Add1	Add2	Add3	Add4	Add5	Add6	Add7	Add8	Add9	Add10	Add11	Add12	copy1	copy2	copy3	copy4	copy5	copy6	copy7	Total	grandtotal
4	3	3658	Lalu	Lead	C	Filter2					£300					6	6		6		6								1	1	2			4	£1,200
9	2	563	Vidu	Manager	Java	Filter2					£400																		8	12				20	£8,000
10	2	563	Vidu	Manager	Java	Filter2					£425																		8	12				20	£8,500
12	2	563	Vidu	Manager	Java	Filter2					£400																		8	13				21	£8,400
16	2	354	Sai	Operator	C++	Filter2					£150							23			2								24					24	£3,600
17	2	333	Fran	Operator	SQL	Filter2					£150						1									1									£0
18	3	239	Jack	Lead	SQL	Filter2					£566											45					4	4		8	4			20	£11,320
19	3	239	Jack	Lead	SQL	Filter2					£300											46					4	4	4	8	4			24	£7,200
23	4	222	Andy	Operator	Java	Filter2					£150																	4			14	8		26	£3,900
24	1	123	Ram	Manager	Java	Filter2					£400						3							55			12					3		15
36	1	26	Som	Operator	C	Filter2					£150

Worksheet: Sheet1

In support of this post






Before destination

_____ Workbook: Workbook2_3.xlsx ( Using Excel 2007 32 bit )

Row\Col	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T
1		Unique ID	Gap	Name	Title	Platform	Salary	Gap	Total	copy1	copy2	copy3	copy4	copy5	copy6	copy7
2

Worksheet: Sheet1

After Destination

_____ Workbook: Workbook2_3.xlsx ( Using Excel 2007 32 bit )

Row\Col	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S
1		Unique ID	Gap	Name	Title	Platform	Salary	Gap	Total	copy1	copy2	copy3	copy4	copy5	copy6	copy7
2		3658		Lalu	Lead	C	£300		24	4			1	1	2
3		563		Vidu	Manager	Java	£425		0	20			8	12
4		354		Sai	Operator	C++	£150		25	24			24
5		333		Fran	Operator	SQL	£150		2
6		239		Jack	Lead	SQL	£566		45	20	4	4		8	4
7		222		Andy	Operator	Java	£150		0	26		4			14	8
8		123		Ram	Manager	Java	£400		58	15	12					3
9		26		Som	Operator	C	£150		0
10

Worksheet: Sheet1

macro for last two posts

Code:

---

Option Explicit
Sub Transfer_marasAlan_3()  '  https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624
Dim a(), cls_v() As String, Rws(), aSum(), arrOut__(), JagdDikIt()
Dim Rng As Range, Rng_v As Range, cel As Range
Dim Wrbk As Workbook, Rw As Long
Dim Pth As String
 Let Pth = ThisWorkbook.Path & Application.PathSeparator  '      Const pth = "C:\Users\L026936\Desktop\Excel\"      '<---- use own path
Const Wnm = "Workbook2_3.xlsx"                            'your workbook name
'    Application.ScreenUpdating = False
Rem 1 the main data range from source
    With ThisWorkbook.Sheets("Sheet1")
    Set Rng = .Range("a1:ai" & 36 & "")    '  main data range    hard coded to 36  for testing and  demonstration        .UsedRange.Rows.Count)
    Let a() = Rng.Value                    '  all data values in the source.  This will end up in the tyopical    arrOut()=AppIndex( a(), Rws(),  Clms() )
    Set Rng_v = Rng.Columns(2).SpecialCells(xlCellTypeVisible)  '  this gives us the range we see , (it is likely as a collection of areas) in the ID column
        If Rng_v.Count > 1 Then
  Rem 2 Make the sums column array, aSum() , and while we are looping we will collect the seen row indicies, Rws()
'      ' ddddddddddddddddddddddd Dictionaray bit ------
        '  Dictionaray    -  The only reason to use this is that its a convenient way to get a unique list thing, or a unique set of things.
        Dim Dik As Object: Set Dik = CreateObject("Scripting.Dictionary")  '      https://excelmacromastery.com/vba-dictionary/
        'Dim d As Scripting.Dictionary: Set d = New Scripting.Dictionary
        Dim aTp() As Variant: ReDim aTp(1 To 3) ' This is a temporary array used to fill the dictionary  Items  it must be dynamic and variant type  - see note +++ below
            For Each cel In Rng_v  '  we effectivelly are going down all the seen rows
                If cel.Row > 1 And cel.Value <> "" Then
                Let Rw = cel.Row
                    If Not Dik.exists(a(Rw, 2)) Then ' -Case we don't yet have any dictionaray item with this ID  key
                    Let aTp(1) = Rw                                          '  row number
                    Let aTp(2) = a(Rw, 35)                                  '  grangtotal for this row
                    Let aTp(3) = .Evaluate("=Sum(o" & Rw & ": z" & Rw & ")") ' Our  column Sums
                    Dik.Add Key:=a(Rw, 2), Item:=aTp() '  The key becomes the ID  ,      The Item is a three element array of      the row number    the columns sum for this row    the gradtotal for this row                              shothand way to do this line is  d(a(r, 2)) = atp
                    Else '                          ' -Case we already have a dictionary item with this key
                    Let aTp() = Dik.Item(a(Rw, 2)) ' we are returning an item that is an array, so the recieving array variable must be dynamic.  the returned element type3s are  Variant  +++
                        If a(Rw, 35) > aTp(2) Then  '  If the grand total for this row and  ID  is  greater than a previous, then ....
                            Let aTp(1) = Rw                                        '  we are replacing ..
                            Let aTp(2) = a(Rw, 35)                                '    .. the item with the relavent  ..
                            Let aTp(3) = .Evaluate("=Sum(o" & Rw & ": z" & Rw & ")") '    .. info from this row
                            Dik(a(Rw, 2)) = aTp()  '  shorthand version for  Dik.Add  Key:=a(Rw, 2), Item:=aTp()
                        End If
                    End If ' end of making or replacing  a dictiuonary item
                Else
                End If
            Next
        ' at this point we have a dictionary that has one  Item  for each  ID
        ' in this last  Dik  bit we use the first and third part  of the 3 element items  in  a pseudo  arrOut()=AppIndex( arrUnjaggedJaged(), Rws() , Clms() )    '    https://www.ozgrid.com/forum/index.php?thread/1227920-slicing-a-2d-array/&postID=1239241#post1239241
            If Dik.Count Then
                'Let JagdDikIt() = Application.Transpose(Dik.items()) '    we can treat an unjagged jagged array  that is a 1 D array of 1 D arrays as if it was a  2 D array  ...  https://eileenslounge.com/viewtopic.php?p=266691#p266691
                Let JagdDikIt() = Dik.items()
                'Let Rws() = Application.Index(JagdDikIt(), 1, Evaluate("row(1:" & UBound(JagdDikIt(), 2) & ")"))                                          '  Application.Transpose(Application.Transpose(Application.Index(v, 1, Evaluate("row(1:" & UBound(v, 2) & ")"))))
                Let Rws() = Application.Index(JagdDikIt(), Evaluate("row(1:" & UBound(JagdDikIt()) + 1 & ")"), 1)                                        '  Application.Transpose(Application.Transpose(Application.Index(v, 1, Evaluate("row(1:" & UBound(v, 2) & ")"))))
                'Let aSum() = Application.Index(JagdDikIt(), 3, Evaluate("row(1:" & UBound(JagdDikIt(), 2) & ")"))                        'Application.Transpose(Application.Transpose(Application.Index(v, 3, Evaluate("row(1:" & UBound(v, 2) & ")"))))
                Let aSum() = Application.Index(JagdDikIt(), Evaluate("row(1:" & UBound(JagdDikIt()) + 1 & ")"), 3)                      'Application.Transpose(Application.Transpose(Application.Index(v, 3, Evaluate("row(1:" & UBound(v, 2) & ")"))))
'      ' ddddddddddddddddddddddddd -----------------------------
            Else
            End If
        Else ' case only a header row to be seen
        End If
    End With
    If Rng_v.Count = 1 Or Dik.Count = 0 Then
        MsgBox "No rows to transfer."
        Exit Sub
    End If
    On Error Resume Next  '  https://eileenslounge.com/viewtopic.php?f=30&t=35861&start=20
    Set Wrbk = Workbooks(Wnm)
        If Wrbk Is Nothing Then
        Workbooks.Open Filename:=Pth & Wnm
        Else
        Workbooks(Wnm).Activate
        End If
    On Error GoTo 0
    With ActiveWorkbook
        With .Sheets("Sheet1")
        Dim vTemp As Variant ' just for demo purposes
        Let vTemp = .UsedRange.Rows(1)
        ' { empty ,  Unique ID  , Gap ,Name  ,  Title ,  Platform  ,  Salary , Gap, Total ,  copy1  , copy2 ,  copy3 ,  copy4  , copy5 ,  copy6 ,  copy7 ,  copy2 ,  copy3 ,  copy4 ,  copy5  , copy6 ,  copy7 ,  Formula7  , Formula8 ,  Formula9  }
        Let vTemp = Rng.Rows(1)
        ' { Number , ID , Name ,  Title ,  Platform ,  Filter  ,  ,  ,  ,    ,Salary ,  ,    ,  ,Add1  ,  Add2 ,  Add3  ,  Add4  ,  Add5 ,  Add6 ,  Add7  ,  Add8 ,  Add9 ,  Add10 ,  Add11 ,  Add12 ,  copy1 ,  copy2 ,  copy3 ,  copy4 ,  copy5  , copy6 ,  copy7  , Total ,  grandtotal  }
        Let 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  , 34 ,  27 ,  28 ,  29  , 30 ,  31 ,  32 ,  33 , 28 , error ,error ,error ,error ,error ,error ,error ,error ,error ,  }
        ' 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 , 34  ,  27 ,  28 ,  29  , 30 ,  31 ,  32 ,  33 , x ,x ,x ,x ,x ,x ,x ,x ,x ,  }
        Let vTemp = Filter(vTemp, "x", False, 0) ' take out the  "x"s
        '  { 2    , 3  , 4 ,  5 ,  11  , 34,  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  }
            With .Range("B2")  '  .UsedRange.Offset(1)
            ' .Resize(, 15).ClearContents
            Let arrOut__() = Application.Index(a(), Rws(), cls_v())
            .Resize(UBound(Rws()), 1) = arrOut__()
            Let Rws() = Evaluate("row(1:" & UBound(Rws()) & ")") '  Using the variable  Rws()  for a sequential indicie list  1; 2; 3 ... etc for all rows in the  arrOut__()
            .Offset(, 2).Cells(1).Resize(UBound(Rws()), 4).Value = Application.Index(arrOut__(), Rws(), Array(2, 3, 4, 5))  '  columns  D - G
            .Offset(, 7).Cells(1).Resize(UBound(Rws())) = aSum()  '  columm I
            .Offset(, 8).Cells(1).Resize(UBound(Rws()), 7).Value = Application.Index(arrOut__(), Rws(), Array(6, 7, 8, 9, 10, 11, 12))  ' Column J to P
            End With
        End With
'        .Save
    End With
'    Set Rng = Nothing
'    Set Rng_v = Nothing
'    Set cel = Nothing
    Set Dik = Nothing
End Sub

---