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
Reply With Quote
Bookmarks