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