microsoft_excel:macros:copy:copy_formulae_down_on_a_sheet_using_arrays
Microsoft Excel - Macros - Copy - Copy formulae down on a sheet using arrays
' Copy formula on the Sheet1 sheet down for all populated rows. ' Speeds this up using Arrays Sub Copy_Formulae_Down_Array() Dim mycell As Variant Dim lastrow_Sheet2 As Long Dim lastrow_Sheet1 As Long Dim working As Variant Dim column_a_Sheet1 As Variant Dim column_d_Sheet1 As Variant Dim column_k_Sheet1 As Variant Dim column_l_Sheet1 As Variant Dim column_n_Sheet1 As Variant Dim column_o_Sheet1 As Variant Dim column_p_Sheet1 As Variant Dim column_r_Sheet1 As Variant Dim column_s_Sheet1 As Variant Dim column_ae_Sheet1 As Variant Dim column_ak_Sheet1 As Variant Dim column_al_Sheet1 As Variant Dim column_a_Sheet2 As Variant Dim column_f_Sheet2 As Variant Dim column_g_Sheet2 As Variant Dim column_i_Sheet2 As Variant Dim column_j_Sheet2 As Variant Dim column_ao_Sheet2 As Variant Dim n As Long ' Ask user. If ctrl_ask_before_running_subroutine = True Then If MsgBox("Copy post Sheet1 formulae down?", vbYesNo) = vbNo Then Exit Sub End If ' Update StatusBar. Application.StatusBar = "Copy post-Sheet1 Formulae down..." With Workbooks(wb_name) ' Get how many rows of data have been loaded into the sheet. lastrow_Sheet2 = Sheets("Sheet2").Cells(Rows.Count, 4).End(xlUp).Row ' Prevent line 2 being deleted - as this contains the formulae which need coping down later. If lastrow_Sheet2 < 3 Then lastrow_Sheet2 = 3 End If With .Sheets("Sheet1") ' Activate the sheet. .Activate ' Get how many rows of data have been loaded into the sheet. lastrow_Sheet1 = .Cells(Rows.Count, 4).End(xlUp).Row ' Prevent line 2 being deleted - as this contains the formulae which need coping down later. If lastrow_Sheet1 < 3 Then lastrow_Sheet1 = 3 End If ReDim working(1 To lastrow_Sheet1, 1) ' Working array working = Range("D3:D" & lastrow_Sheet1) ' load with dummy values. ReDim column_a_Sheet1(1 To lastrow_Sheet1, 1) ReDim column_k_Sheet1(1 To lastrow_Sheet1, 1) ReDim column_l_Sheet1(1 To lastrow_Sheet1, 1) ReDim column_n_Sheet1(1 To lastrow_Sheet1, 1) ReDim column_o_Sheet1(1 To lastrow_Sheet1, 1) ReDim column_p_Sheet1(1 To lastrow_Sheet1, 1) ReDim column_r_Sheet1(1 To lastrow_Sheet1, 1) ReDim column_s_Sheet1(1 To lastrow_Sheet1, 1) ReDim column_ae_Sheet1(1 To lastrow_Sheet1, 1) ReDim column_ak_Sheet1(1 To lastrow_Sheet1, 1) ReDim column_al_Sheet1(1 To lastrow_Sheet1, 1) ReDim column_a_Sheet2(1 To lastrow_Sheet2, 1) ReDim column_f_Sheet2(1 To lastrow_Sheet2, 1) ReDim column_g_Sheet2(1 To lastrow_Sheet2, 1) ReDim column_i_Sheet2(1 To lastrow_Sheet2, 1) ReDim column_j_Sheet2(1 To lastrow_Sheet2, 1) ReDim column_ao_Sheet2(1 To lastrow_Sheet2, 1) ' Column AE ' FX_Rate working = Range("AE3:AE" & lastrow_Sheet1) column_ae_Sheet1 = Range("AE3:AE" & lastrow_Sheet1) For n = LBound(working) To UBound(working) If Not column_ae_Sheet1(n, 1) Like "*[0-9]*" Then working(n, 1) = 1 End If Next n .Range("AE3:AE" & lastrow_Sheet1).Value = working ' Column P - needed before column N ' =IF(R2="",K2*S2/100,K2*R2/100) column_r_Sheet1 = Range("R3:R" & lastrow_Sheet1) column_k_Sheet1 = Range("O3:O" & lastrow_Sheet1) column_s_Sheet1 = Range("S3:S" & lastrow_Sheet1) For n = LBound(working) To UBound(working) If column_r_Sheet1(n, 1) = "" Then working(n, 1) = column_k_Sheet1(n, 1) * column_s_Sheet1(n, 1) / 100 Else working(n, 1) = column_k_Sheet1(n, 1) * column_r_Sheet1(n, 1) / 100 End If Next n .Range("P3:P" & lastrow_Sheet1).Value = working ' Column N - needed before column M ' =P2*AE2 column_p_Sheet1 = Range("P3:P" & lastrow_Sheet1) column_ae_Sheet1 = Range("AE3:AE" & lastrow_Sheet1) For n = LBound(working) To UBound(working) working(n, 1) = column_p_Sheet1(n, 1) * column_ae_Sheet1(n, 1) Next n .Range("N3:N" & lastrow_Sheet1).Value = working ' Column M '=L2-N2 column_l_Sheet1 = Range("L3:L" & lastrow_Sheet1) column_n_Sheet1 = Range("N3:N" & lastrow_Sheet1) For n = LBound(working) To UBound(working) working(n, 1) = column_l_Sheet1(n, 1) - column_n_Sheet1(n, 1) Next n .Range("M3:M" & lastrow_Sheet1).Value = working ' Column Q ' =IF(R2="",S2*100,R2*100) column_r_Sheet1 = Range("R3:R" & lastrow_Sheet1) column_s_Sheet1 = Range("S3:S" & lastrow_Sheet1) For n = LBound(working) To UBound(working) If column_r_Sheet1(n, 1) = "" Then working(n, 1) = column_s_Sheet1(n, 1) * 100 Else working(n, 1) = column_r_Sheet1(n, 1) * 100 End If Next n .Range("Q3:Q" & lastrow_Sheet1).Value = working ' Column AI ' =IF(ISNA(VLOOKUP(D2,Sheet2!G$1:G$52435,1,FALSE)),"NOT FOUND","FOUND") column_d_Sheet1 = Range("D3:D" & lastrow_Sheet1) column_g_Sheet2 = Range("G3:G" & lastrow_Sheet2) For n = LBound(working) To UBound(working) working(n, 1) = ArrayFindEx(column_g_Sheet2, column_d_Sheet1(n, 1), "FOUND", "NOT FOUND") Next n .Range("AI3:AI" & lastrow_Sheet1).Value = working ' Column AJ 'D2=D1 .Range("AJ2:AJ2").AutoFill Destination:=.Range("AJ2:AJ" & lastrow_Sheet1) ' Column AK ' =IF(COUNTIF($A$1:A2,A2)>1,"AGGREGATE",SUMIF($A$1:$A$2227,A2,$L$1:$L$2227)-SUMIF(Sheet2!$A$1:$A$52435,A2,Sheet2!$F$1:$F$52435)) column_a_Sheet1 = Range("A3:A" & lastrow_Sheet1) column_l_Sheet1 = Range("L3:L" & lastrow_Sheet1) column_a_Sheet2 = Sheets("Sheet2").Range("A3:A" & lastrow_Sheet2) column_f_Sheet2 = Sheets("Sheet2").Range("F3:F" & lastrow_Sheet2) For n = LBound(working) To UBound(working) If ArrayCountIf(column_a_Sheet1, column_a_Sheet1(n, 1)) > 1 Then working(n, 1) = "AGGREGATE" Else working(n, 1) = ArraySumIf(column_a_Sheet1, column_a_Sheet1(n, 1), column_l_Sheet1) - ArraySumIf(column_a_Sheet2, column_a_Sheet1(n, 1), column_f_Sheet2) End If Next n .Range("AK3:AK" & lastrow_Sheet1).Value = working ' Column AL ' =IF(A2=A1,AL1,IF(AND(AK2>-0.1,AK2<0.1),"MATCHED GROSS AMOUNT ISIN BY MONTH","GROSS AMOUNT NOT MATCHED ISIN BY MONTH")) ' column_a_Sheet1 = Range("A3:A" & lastrow_Sheet1) ' column_aj_Sheet1 = Range("AJ3:AJ" & lastrow_Sheet1) ' column_ai_Sheet1 = Range("AI3:AJ" & lastrow_Sheet1) ' For n = LBound(working) To UBound(working) ' If column_a_Sheet1(n, 1) = column_a_Sheet1(n - 1, 1) Then ' working(n, 1) = column_aj_Sheet1(n - 1, 1) ' Else ' If column_ai_Sheet1(n, 1) > -0.1 And column_ai_Sheet1(n, 1) < 0.1 Then ' working(n, 1) = "MATCHED GROSS AMOUNT ISIN BY MONTH" ' Else ' working(n, 1) = "GROSS AMOUNT NOT MATCHED ISIN BY MONTH" ' End If ' End If ' Next n ' ' .Range("AM3:AM" & lastrow_Sheet1).Value = working .Range("AL2").AutoFill Destination:=.Range("AL2:AL" & lastrow_Sheet1) .Range("AL2:AL" & lastrow_Sheet1).Calculate .Range("AL3:AL" & lastrow_Sheet1) = .Range("AL3:AL" & lastrow_Sheet1).Value ' Column AM ' =IF(COUNTIF($A$1:A2,A2)>1,"AGGREGATE",SUMIF($A$1:$A$2227,A2,$K$1:$K$2227)-SUMIF(Sheet2!$A$1:A$52435,A2,Sheet2!$AO$1:$AO$52435)) column_a_Sheet1 = Range("A3:A" & lastrow_Sheet1) column_k_Sheet1 = Range("K3:K" & lastrow_Sheet1) column_a_Sheet2 = Sheets("Sheet2").Range("A3:A" & lastrow_Sheet2) column_ao_Sheet2 = Sheets("Sheet2").Range("AO3:AO" & lastrow_Sheet2) For n = LBound(working) To UBound(working) If ArrayCountIf(column_a_Sheet1, column_a_Sheet1(n, 1)) > 1 Then working(n, 1) = "AGGREGATE" Else working(n, 1) = ArraySumIf(column_a_Sheet1, column_a_Sheet1(n, 1), column_k_Sheet1) - ArraySumIf(column_a_Sheet2, column_a_Sheet1(n, 1), column_ao_Sheet2) End If Next n .Range("AM3:AM" & lastrow_Sheet1).Value = working ' Column AR ' =IF(COUNTIF($A$1:A2,A2)>1,"AGGREGATE",SUMIF($A$1:$A$2227,A2,$P$1:$P$2227)-SUMIF(Sheet2!$A$1:$A$52435,A2,Sheet2!$J$1:$J$52435)) column_a_Sheet1 = Range("A3:A" & lastrow_Sheet1) column_p_Sheet1 = Range("P3:P" & lastrow_Sheet1) column_a_Sheet2 = Sheets("Sheet2").Range("A3:A" & lastrow_Sheet2) column_j_Sheet2 = Sheets("Sheet2").Range("J3:J" & lastrow_Sheet2) For n = LBound(working) To UBound(working) If ArrayCountIf(column_a_Sheet1, column_a_Sheet1(n, 1)) > 1 Then working(n, 1) = "AGGREGATE" Else working(n, 1) = ArraySumIf(column_a_Sheet1, column_a_Sheet1(n, 1), column_p_Sheet1) - ArraySumIf(column_a_Sheet2, column_a_Sheet1(n, 1), column_j_Sheet2) End If Next n .Range("AR3:AR" & lastrow_Sheet1).Value = working ' Column AS ' =IF(A2=A1,AS1,IF(AND(AR2>-0.1,AR2<0.1),"MATCHED TAX AMOUNT ISIN BY MONTH","TAX AMOUNT NOT MATCHED ISIN BY MONTH")) ' column_a_Sheet1 = Range("A3:A" & lastrow_Sheet1) ' column_aq_Sheet1 = Range("AQ3:AQ" & lastrow_Sheet1) ' column_ap_Sheet1 = Range("AP3:AP" & lastrow_Sheet1) ' For n = LBound(working) To UBound(working) ' If column_a_Sheet1(n, 1) = column_a_Sheet1(n - 1, 1) Then ' working(n, 1) = column_aq_Sheet1(n - 1, 1) ' Else ' If column_ap_Sheet1(n, 1) > -0.1 And column_ap_Sheet1(n, 1) < 0.1 Then ' working(n, 1) = "MATCHED TAX AMOUNT ISIN BY MONTH" ' Else ' working(n, 1) = "TAX AMOUNT NOT MATCHED ISIN BY MONTH" ' End If ' End If ' Next n ' ' .Range("AS3:AS" & lastrow_Sheet1).Value = working .Range("AS2").AutoFill Destination:=.Range("AS2:AS" & lastrow_Sheet1) .Range("AS2:AS" & lastrow_Sheet1).Calculate .Range("AS3:AS" & lastrow_Sheet1) = .Range("AS3:AS" & lastrow_Sheet1).Value ' Column AT ' =IF(COUNTIF($A$1:A2,A2)>1,"AGGREGATE",SUMIF($A$1:$A$2227,A2,$O$1:$O$2227)-SUMIF(Sheet2!$A$1:$A$52435,A2,Sheet2!$I$1:$I$52435)) column_a_Sheet1 = Range("A3:A" & lastrow_Sheet1) column_o_Sheet1 = Range("O3:O" & lastrow_Sheet1) column_a_Sheet2 = Sheets("Sheet2").Range("A3:A" & lastrow_Sheet2) column_i_Sheet2 = Sheets("Sheet2").Range("I3:I" & lastrow_Sheet2) For n = LBound(working) To UBound(working) If ArrayCountIf(column_a_Sheet1, column_a_Sheet1(n, 1)) > 1 Then working(n, 1) = "AGGREGATE" Else working(n, 1) = ArraySumIf(column_a_Sheet1, column_a_Sheet1(n, 1), column_o_Sheet1) - ArraySumIf(column_a_Sheet2, column_a_Sheet1(n, 1), column_i_Sheet2) End If Next n .Range("AT3:AT" & lastrow_Sheet1).Value = working End With End With ' Clear all objects. Set mycell = Nothing Set working = Nothing Set column_a_Sheet1 = Nothing Set column_d_Sheet1 = Nothing Set column_k_Sheet1 = Nothing Set column_l_Sheet1 = Nothing Set column_n_Sheet1 = Nothing Set column_o_Sheet1 = Nothing Set column_p_Sheet1 = Nothing Set column_r_Sheet1 = Nothing Set column_s_Sheet1 = Nothing Set column_ae_Sheet1 = Nothing Set column_ak_Sheet1 = Nothing Set column_al_Sheet1 = Nothing Set column_a_Sheet2 = Nothing Set column_f_Sheet2 = Nothing Set column_i_Sheet2 = Nothing Set column_j_Sheet2 = Nothing Set column_ao_Sheet2 = Nothing End Sub
microsoft_excel/macros/copy/copy_formulae_down_on_a_sheet_using_arrays.txt · Last modified: 2021/08/04 15:08 by peter