post to use later
post to use later
In support of this post
Before Source worksheet
_____ Workbook: Transfer data_marasAlan_1.xlsm ( Using Excel 2007 32 bit )
Worksheet: Sheet1
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
In support of this post
Before destination worksheet
_____ Workbook: Workbook2_1.xlsx ( Using Excel 2007 32 bit )
Worksheet: Sheet1
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
Destination After
_____ Workbook: Workbook2_1.xlsx ( Using Excel 2007 32 bit )
Worksheet: Sheet1
Row\Col 3658 Lalu Lead C 563 Vidu_xx Manager Java 563 Vidu_max Manager Java 563 Vidu Manager Java 354 Sai Operator C++ 333 Fran Operator SQL 239 Jack_max Lead SQL 239 Jack Lead SQL 222 Andy Operator Java 123 Ram Manager Java 26 Som Operator C
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 )
Worksheet: Sheet1
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
In support of this post
Designation workbook before
_____ Workbook: Workbook2_2.xlsx ( Using Excel 2007 32 bit )
Worksheet: sheet1
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
Destination workbook after running macro Sub Transfer_marasAlan_2()
_____ Workbook: Workbook2_2.xlsx ( Using Excel 2007 32 bit )
Worksheet: sheet1
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
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 )
Worksheet: Sheet1
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 9 2 563 Vidu Manager Java Filter2 £400 8 12 10 2 563 Vidu Manager Java Filter2 £425 8 12 12 2 563 Vidu Manager Java Filter2 £400 8 13 16 2 354 Sai Operator C++ Filter2 £150 23 2 24 17 2 333 Fran Operator SQL Filter2 £150 1 1 18 3 239 Jack Lead SQL Filter2 £566 45 4 4 8 4 19 3 239 Jack Lead SQL Filter2 £300 46 4 4 4 8 4 23 4 222 Andy Operator Java Filter2 £150 4 14 8 24 1 123 Ram Manager Java Filter2 £400 3 55 12 3 36 1 26 Som Operator C Filter2 £150
In support of this post
Before destination
_____ Workbook: Workbook2_3.xlsx ( Using Excel 2007 32 bit )
Worksheet: Sheet1
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
After Destination
_____ Workbook: Workbook2_3.xlsx ( Using Excel 2007 32 bit )
Worksheet: Sheet1
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
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
Posting Permissions
Reply With Quote
Bookmarks