Macro runs slowly

[Cakz Primz]

Dear all,

I need your help and kind assistance.

I have a workbook in .xlsb extension, 6MB size with only 1 sheet, no linking to another workbook. And I have not open another workbook.
The original data is csv, with Purchase Order number in text format, so I need to change into number format.
The number of rows is 85,000 and the columns used until AE (31 columns, starting from column A).

It takes more than 3 minutes just to run the code below:

Sub Banyak()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    Dim lRow As Long
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    With ws
    
    .Range("B2:B" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[31])"
    .Range("C2:C" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[33])"
    .Range("D2:D" & lRow).FormulaR1C1 = "=RC[-1]/RC[-2]"
    .Range("E2:E" & lRow).FormulaR1C1 = "=RC[-3]-RC[-2]"
    .Range("F2:F" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[1])"
    .Range("G2:G" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[4])"
    .Range("H2:H" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[15])"
    .Range("I2:I" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[16])"
    .Range("J2:J" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[6])"
    .Range("K2:K" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[6])"
    .Range("L2:L" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[19])"
    .Range("M2:M" & lRow).FormulaR1C1 = "=IF(RC[-1]<RC[-3],""Ahead"",IF(RC[-1]=RC[-3],""On schedule"",""Late""))"
    .Range("B2:M" & lRow).Value = .Range("B2:M" & lRow).Value
    End With
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

Is there something wrong with the code? or perhaps there is another better solution to accelerate?

Thank you
prima - Indonesia

 

[Cakz Primz]

Dear all,

I need your help and kind assistance.

I have a workbook in .xlsb extension, 6MB size with only 1 sheet, no linking to another workbook. And I have not open another workbook.
The original data is csv, with Purchase Order number in text format, so I need to change into number format.
The number of rows is 85,000 and the columns used until AE (31 columns, starting from column A).

It takes more than 3 minutes just to run the code below:

Sub Banyak()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim ws As Worksheet
    Set ws = ActiveSheet
   
    Dim lRow As Long
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    With ws
   
    .Range("B2:B" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[31])"
    .Range("C2:C" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[33])"
    .Range("D2:D" & lRow).FormulaR1C1 = "=RC[-1]/RC[-2]"
    .Range("E2:E" & lRow).FormulaR1C1 = "=RC[-3]-RC[-2]"
    .Range("F2:F" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[1])"
    .Range("G2:G" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[4])"
    .Range("H2:H" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[15])"
    .Range("I2:I" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[16])"
    .Range("J2:J" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[6])"
    .Range("K2:K" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[6])"
    .Range("L2:L" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[19])"
    .Range("M2:M" & lRow).FormulaR1C1 = "=IF(RC[-1]<RC[-3],""Ahead"",IF(RC[-1]=RC[-3],""On schedule"",""Late""))"
    .Range("B2:M" & lRow).Value = .Range("B2:M" & lRow).Value
    End With
   
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

Is there something wrong with the code? or perhaps there is another better solution to accelerate?

Thank you
prima - Indonesia

Dear all,

Sorry...below is the correct VBA code:

Sub Summarize()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    

    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    Dim lRow As Long
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    With ws
    
    .Range("AF4:AF" & lRow).FormulaR1C1 = "=VALUE(RC[-27])"
    .Range("AG4:AG" & lRow).FormulaR1C1 = "=COUNTIF(C[-28],RC[-1])"
    .Range("AH4:AH" & lRow).FormulaR1C1 = "=COUNTIFS(C5,RC32,C22,R3C)"
    .Range("AI4:AI" & lRow).FormulaR1C1 = "=COUNTIFS(C5,RC32,C22,R3C)"
    .Range("AJ4:AJ" & lRow).FormulaR1C1 = "=COUNTIFS(C5,RC32,C22,R3C)"
    .Range("AK4:AK" & lRow).FormulaR1C1 = "=COUNTIFS(C5,RC32,C22,R3C)"
    .Range("AL4:AL" & lRow).FormulaR1C1 = "=COUNTIFS(C5,RC32,C22,R3C)"
    .Range("AM4:AM" & lRow).FormulaR1C1 = "=COUNTIFS(C5,RC32,C22,R3C)"
    .Range("AN4:AN" & lRow).FormulaR1C1 = "=COUNTIFS(C5,RC32,C22,R3C)"
    .Range("AO4:AO" & lRow).FormulaR1C1 = "=COUNTIFS(C5,RC32,C22,R3C)"
    .Range("AF4:AO" & lRow).Value = .Range("AF4:AO" & lRow).Value
    End With
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Thank you very much

 

[kevin9999]

Could you provide a small sample of your data using the XL2BB add in?

 

[Cakz Primz]

Could you provide a small sample of your data using the XL2BB add in?

Purchase Order Status.xlsx
	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	AJ	AK	AL	AM	AN	AO
1	InfoProvider Description	Material Status Report
2	Last Data Update	22.12.2022 05:24:35
3	Project	PR Requesting Name	PR Code		PO Number	Inspection Level	Vendor Name	PO Description	PO item description	Expediter		PO item number	ASO sub-item Nr	ASO sub-item description	Inspection Release Note Number	PO Contractual delivery date	Expected Delivery Date	ASO released date	Delay cd.1 by Exp.	ASO sub-item Status	SF/Batch Status		Incoterm		Delivery Point Country	Main Leg Transport Mean: EXPECTED Departure Date	Main Leg Transport Mean: ACTUAL Departure Date	Main Leg Transport Mean: EXPECTED Arrival Date	Main Leg Transport Mean: ACTUAL Arrival Date	FORECAST arrival at site	ACTUAL Arrival At Site		Line Items	Accepted Documents	Arrival at Main Leg	Arrival at the site	Available	Initial	Main means of Tr.Arr	Not Assigned	Reversed
4	BP TANGGUH Onshore E	ARIF R.	11651700	Cables for Building	1315870	R	PT SINAR CEMERLANG SEMESTA	CABLES FOR BUILDING CLUSTER 2 - RFM 2170	DRUM 2	M28	Abdul Haris Hutagaol	2	#	Not assigned	145520	30.04.2020	30.06.2020	03.07.2020	V10	ARRIVAL TO SITE	60	ARRIVAL AT THE SITE	DDP	Delivered cleared by	Indonesia	#	#	#	#	#	30.06.2020	1315870	1	0	0	1	0	0	0	0	0
5	BP TANGGUH Onshore E	FERDIAN	11639268	Stationeries and Gro	1309410	N	PT DATASCRIP	STATIONERIES AND GROCERIES FOR JAN - MAR	ERASER / PENGHAPUS PENSIL MERK BOXI	MC2	Djajadi Doni	19	#	Not assigned	Not assigned	31.03.2020	06.02.2020	27.12.2021	Not assigned	ARRIVAL TO SITE	60	ARRIVAL AT THE SITE	DDP	Delivered cleared by	Indonesia	#	#	#	#	#	06.02.2020	1309410	61	0	0	60	0	1	0	0	0
6	BP TANGGUH Onshore E	JOY ANDREAN	11609267	OZILITE AUTOMATIC LI	1286918	N	PT. RIVERA MAKMUR ABADI	OZILITE AUTOMATIC LIGHTER	OZILITE 240 VOLTS WALL MOUNTED	M28	Abdul Haris Hutagaol	1	#	Not assigned	Not assigned	13.09.2019	27.09.2019	29.01.2020	V10	ARRIVAL TO SITE	60	ARRIVAL AT THE SITE	DDP	Delivered cleared by	Indonesia	#	#	#	#	#	27.09.2019	1286918	1	0	0	1	0	0	0	0	0
7	BP TANGGUH Onshore E	K. TAKINAWA	11792898	Purchasing Material	1412145	C	PT. PARADISE PERKASA	PURCHASING MATERIAL FOR TP-011-0005-01	NPS:3/4X1/2-THK:2.87MMX2.77MM -ECC.	MC9	Omega Maruli Pohan	2	#	Not assigned	165349	12.09.2022	17.09.2022	21.10.2022	C10	ARRIVAL TO SITE	60	ARRIVAL AT THE SITE	DDP	Delivered cleared by	Not assigned	#	#	#	#	#	17.09.2022	1412145	2	0	0	2	0	0	0	0	0
8	BP TANGGUH Onshore E	SLAMET R.	11631122	SEAL SPARE PARTS HIL	1302069	N	PT. HILTI NUSANTARA	SEAL SPARE PARTS HILTI	ANCHOR ROD HAS-U 8.8 HDG M20X260	MC9	Omega Maruli Pohan	3	#	Not assigned	Not assigned	13.12.2019	12.12.2019	17.07.2020	Not assigned	ARRIVAL TO SITE	60	ARRIVAL AT THE SITE	DDP	Delivered cleared by	Indonesia	#	#	#	#	#	12.12.2019	1302069	4	0	0	4	0	0	0	0	0
9	BP TANGGUH Onshore E	SLAMET R.	11631122	SEAL SPARE PARTS HIL	1302069	N	PT. HILTI NUSANTARA	SEAL SPARE PARTS HILTI	INJECTABLE MORTAR HIT-RE 500 V3/500/1	MC9	Omega Maruli Pohan	4	#	Not assigned	Not assigned	13.12.2019	12.12.2019	17.07.2020	Not assigned	ARRIVAL TO SITE	60	ARRIVAL AT THE SITE	DDP	Delivered cleared by	Indonesia	#	#	#	#	#	12.12.2019	1302069	4	0	0	4	0	0	0	0	0
10	BP TANGGUH Onshore E	SLAMET R.	11631122	SEAL SPARE PARTS HIL	1302069	N	PT. HILTI NUSANTARA	SEAL SPARE PARTS HILTI	SEAL OUTSIDE PART NO : 207700	MC9	Omega Maruli Pohan	2	#	Not assigned	Not assigned	13.12.2019	12.12.2019	17.07.2020	Not assigned	ARRIVAL TO SITE	60	ARRIVAL AT THE SITE	DDP	Delivered cleared by	Indonesia	#	#	#	#	#	12.12.2019	1302069	4	0	0	4	0	0	0	0	0
11	BP TANGGUH Onshore E	SLAMET R.	11631122	SEAL SPARE PARTS HIL	1302069	N	PT. HILTI NUSANTARA	SEAL SPARE PARTS HILTI	SEAL OUTSIDE PART NO : 406660	MC9	Omega Maruli Pohan	1	#	Not assigned	Not assigned	13.12.2019	12.12.2019	17.07.2020	Not assigned	ARRIVAL TO SITE	60	ARRIVAL AT THE SITE	DDP	Delivered cleared by	Indonesia	#	#	#	#	#	12.12.2019	1302069	4	0	0	4	0	0	0	0	0
12	BP TANGGUH Onshore E	.	11611988	PPE MATERIALS	1288622	N	PT. BERKAT NIAGA DUNIA	PPE MATERIALS	SAFETY BOOTS	M28	Abdul Haris Hutagaol	1	#	Not assigned	Not assigned	18.09.2019	05.02.2020	29.05.2020	V10	ARRIVAL TO SITE	60	ARRIVAL AT THE SITE	DDP	Delivered cleared by	Indonesia	#	#	#	#	#	05.02.2020	1288622	5	0	0	5	0	0	0	0	0
13	BP TANGGUH Onshore E	.	11611988	PPE MATERIALS	1288622	N	PT. BERKAT NIAGA DUNIA	PPE MATERIALS	SAFETY BOOTS	M28	Abdul Haris Hutagaol	2	#	Not assigned	Not assigned	18.09.2019	05.02.2020	29.05.2020	V10	ARRIVAL TO SITE	60	ARRIVAL AT THE SITE	DDP	Delivered cleared by	Indonesia	#	#	#	#	#	05.02.2020	1288622	5	0	0	5	0	0	0	0	0
14	BP TANGGUH Onshore E	.	11611988	PPE MATERIALS	1288622	N	PT. BERKAT NIAGA DUNIA	PPE MATERIALS	SAFETY BOOTS	M28	Abdul Haris Hutagaol	3	#	Not assigned	Not assigned	18.09.2019	05.02.2020	29.05.2020	V10	ARRIVAL TO SITE	60	ARRIVAL AT THE SITE	DDP	Delivered cleared by	Indonesia	#	#	#	#	#	05.02.2020	1288622	5	0	0	5	0	0	0	0	0
15	BP TANGGUH Onshore E	.	11611988	PPE MATERIALS	1288622	N	PT. BERKAT NIAGA DUNIA	PPE MATERIALS	SAFETY BOOTS	M28	Abdul Haris Hutagaol	4	#	Not assigned	Not assigned	18.09.2019	05.02.2020	29.05.2020	V10	ARRIVAL TO SITE	60	ARRIVAL AT THE SITE	DDP	Delivered cleared by	Indonesia	#	#	#	#	#	05.02.2020	1288622	5	0	0	5	0	0	0	0	0
16	BP TANGGUH Onshore E	.	11611988	PPE MATERIALS	1288622	N	PT. BERKAT NIAGA DUNIA	PPE MATERIALS	SAFETY BOOTS	M28	Abdul Haris Hutagaol	5	#	Not assigned	Not assigned	18.09.2019	05.02.2020	29.05.2020	V10	ARRIVAL TO SITE	60	ARRIVAL AT THE SITE	DDP	Delivered cleared by	Indonesia	#	#	#	#	#	05.02.2020	1288622	5	0	0	5	0	0	0	0	0
17	BP TANGGUH Onshore E	.	11611988	PPE MATERIALS	1288639	N	PT.WAHANA SAFETY INDONESIA	PPE MATERIALS	FACE SHIELD (ATTACHED TO HELMET)	M28	Abdul Haris Hutagaol	6	#	Not assigned	Not assigned	18.09.2019	04.10.2019	07.10.2019	V10	ARRIVAL TO SITE	60	ARRIVAL AT THE SITE	DDP	Delivered cleared by	Indonesia	#	#	#	#	#	04.10.2019	1288639	3	0	0	3	0	0	0	0	0
DataSource

Cell Formulas
Range	Formula
AF4	AF4	=VALUE(E4)
AG4	AG4	=COUNTIF(E:E,AF4)
AH4:AO4	AH4	=COUNTIFS($E:$E,$AF4,$V:$V,AH$3)

 

[kevin9999]

Thank you

 

[Cakz Primz]

Dear kevin9999,

Below is the formula in XL2BB:

Purchase Order Status.xlsx
	AF	AG	AH	AI	AJ	AK	AL	AM	AN	AO
3		Line Items	Accepted Documents	Arrival at Main Leg	Arrival at the site	Available	Initial	Main means of Tr.Arr	Not Assigned	Reversed
4	1315870	1	0	0	1	0	0	0	0	0
DataSource

Cell Formulas
Range	Formula
AF4	AF4	=VALUE(E4)
AG4	AG4	=COUNTIF(E:E,AF4)
AH4:AO4	AH4	=COUNTIFS($E:$E,$AF4,$V:$V,AH$3)

Thank you so much for your kind attention and help.
Regards,
Prima - Indonesia

 

[kevin9999]

I'm not entirely happy with it, but the following code (based on your XL2BB sample extended down) takes around 10 seconds for 85K+ rows. Let me know how you go with it.

Option Explicit
Dim LRow As Long
Dim ws As Worksheet
Sub Cakz_Primz()
    Dim t As Double: t = Timer
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlManual
    End With
    
    Set ws = Worksheets("DataSource")   '<< Check sheet name
    LRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
    
    '1. Get values into column AF
    With ws
        .Range("E4:E" & LRow).Copy
        .Range("AF4").PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    End With
    
    '2. Get values into column AG
    CountIfAF
    
    '3 Get values into AH:AO
    CountIfAH
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlAutomatic
    End With
    
    MsgBox "Completed " & LRow - 3 & " rows in " & Timer - t & "seconds."
End Sub

Sub CountIfAF()
    Dim R As Long, s As String, Data As Variant, Result As Variant
    Data = Range("E4:E" & LRow)
    ReDim Result(1 To UBound(Data), 1 To 1)
    
    With CreateObject("Scripting.Dictionary")
      For R = 1 To UBound(Data)
        s = CStr(Data(R, 1))
        .Item(s) = .Item(s) + 1
      Next
    For R = 1 To UBound(Data)
        Result(R, 1) = .Item(CStr(Data(R, 1)))
      Next
    End With
    Range("AG4").Resize(UBound(Result)) = Result
End Sub

Sub CountIfAH()
    Dim R As Long, s As String, Data, Result
    Dim ar1, i As Long, x As String
    Data = ws.Range("E4:V" & LRow)
    ReDim Result(1 To UBound(Data), 1 To 1)
    
    With CreateObject("Scripting.Dictionary")
        For i = 34 To 41
            x = ws.Cells(3, i)
            For R = 1 To UBound(Data)
              If UCase(Data(R, 18)) = UCase(x) Then
                s = CStr(Data(R, 1))
                .Item(s) = .Item(s) + 1
              End If
            Next
            For R = 1 To UBound(Data)
                Result(R, 1) = .Item(CStr(Data(R, 1)))
            Next
            Cells(4, i).Resize(UBound(Result)) = Result
            .RemoveAll
        Next i
    End With
End Sub

 

[Alex Blakenburg]

I am not entirely happy with mine either but here is another version.

Sub Summarize_v02()

    Dim t As Double: t = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim ws As Worksheet
    Dim LRow As Long
    Dim dictPO_SumRow As Object, dictPOKey As String
    Dim dictStatus_Col As Object, dictStatusKey As String
    Dim rngSrc As Range, rngOut As Range, cellHdg As Range
    Dim arrSrc As Variant, arrSum() As Variant, arrOut() As Variant
    Dim iSrc As Long, iSum As Long, iSumNew As Long, iHdg, SumColID As Long, j As Long
        
    Set ws = ActiveSheet
    With ws
        LRow = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rngSrc = .Range("A4:AO" & LRow)                         '<-- Modify as required
        arrSrc = rngSrc.Value
        Set rngOut = .Range("AF4:AO" & LRow)                        '<-- Modify as required - repeated PO No and Count Columns
        ReDim arrSum(1 To UBound(arrSrc), 1 To rngOut.Columns.Count)
        ReDim arrOut(1 To UBound(arrSrc), 1 To rngOut.Columns.Count)
    End With
    
    ' Load Dictionary for Headings / Categories relative position
    Set dictStatus_Col = CreateObject("Scripting.dictionary")
    For Each cellHdg In rngOut.Offset(-1).Cells
        dictStatusKey = UCase(cellHdg.Value)
        If Not dictStatus_Col.exists(dictStatusKey) Then
            iHdg = iHdg + 1
            If cellHdg.Value = "" Then dictStatusKey = "PO NO"          ' Not used just a place holder
            dictStatus_Col(dictStatusKey) = iHdg
        End If
    Next cellHdg
    
    
    ' Load Dictionary Unique PO nos and total count by Category
    Set dictPO_SumRow = CreateObject("Scripting.dictionary")
    For iSrc = 1 To UBound(arrSrc)
        dictPOKey = CStr(arrSrc(iSrc, 5))
        If Not dictPO_SumRow.exists(dictPOKey) Then
            iSumNew = iSumNew + 1
            dictPO_SumRow(dictPOKey) = iSumNew
        End If
        iSum = dictPO_SumRow(dictPOKey)
        arrSum(iSum, 1) = arrSrc(iSrc, 5)
        arrSum(iSum, 2) = arrSum(iSum, 2) + 1
        
        dictStatusKey = UCase(arrSrc(iSrc, 22))
        SumColID = dictStatus_Col(dictStatusKey)
        arrSum(iSum, SumColID) = arrSum(iSum, SumColID) + 1
    Next iSrc
    
    ' Load output array based on all rows in source and outputting count values against repeating PO numbers
    For iSrc = 1 To UBound(arrSrc)
        arrOut(iSrc, 1) = arrSrc(iSrc, 5)
        dictPOKey = CStr(arrSrc(iSrc, 5))
        For j = 2 To UBound(arrSum, 2)
            arrOut(iSrc, j) = arrSum(dictPO_SumRow(dictPOKey), j)
        Next j
    Next iSrc
   
    rngOut.Resize(UBound(arrOut)) = arrOut

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "Completed " & UBound(arrSrc) & " rows in " & Timer - t & "seconds."
End Sub

 

[kvsrinivasamurthy]

To convert text format to number format.
Select the range
Data->> Text to columns
Delimited->>Next->>Next
Select Date ->> Finish

 

[Cakz Primz]

I'm not entirely happy with it, but the following code (based on your XL2BB sample extended down) takes around 10 seconds for 85K+ rows. Let me know how you go with it.

Option Explicit
Dim LRow As Long
Dim ws As Worksheet
Sub Cakz_Primz()
    Dim t As Double: t = Timer
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlManual
    End With
   
    Set ws = Worksheets("DataSource")   '<< Check sheet name
    LRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
   
    '1. Get values into column AF
    With ws
        .Range("E4:E" & LRow).Copy
        .Range("AF4").PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    End With
   
    '2. Get values into column AG
    CountIfAF
   
    '3 Get values into AH:AO
    CountIfAH
   
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlAutomatic
    End With
   
    MsgBox "Completed " & LRow - 3 & " rows in " & Timer - t & "seconds."
End Sub

Sub CountIfAF()
    Dim R As Long, s As String, Data As Variant, Result As Variant
    Data = Range("E4:E" & LRow)
    ReDim Result(1 To UBound(Data), 1 To 1)
   
    With CreateObject("Scripting.Dictionary")
      For R = 1 To UBound(Data)
        s = CStr(Data(R, 1))
        .Item(s) = .Item(s) + 1
      Next
    For R = 1 To UBound(Data)
        Result(R, 1) = .Item(CStr(Data(R, 1)))
      Next
    End With
    Range("AG4").Resize(UBound(Result)) = Result
End Sub

Sub CountIfAH()
    Dim R As Long, s As String, Data, Result
    Dim ar1, i As Long, x As String
    Data = ws.Range("E4:V" & LRow)
    ReDim Result(1 To UBound(Data), 1 To 1)
   
    With CreateObject("Scripting.Dictionary")
        For i = 34 To 41
            x = ws.Cells(3, i)
            For R = 1 To UBound(Data)
              If UCase(Data(R, 18)) = UCase(x) Then
                s = CStr(Data(R, 1))
                .Item(s) = .Item(s) + 1
              End If
            Next
            For R = 1 To UBound(Data)
                Result(R, 1) = .Item(CStr(Data(R, 1)))
            Next
            Cells(4, i).Resize(UBound(Result)) = Result
            .RemoveAll
        Next i
    End With
End Sub

Dear kevin9999,

Thanks so much for your kind assistance and help.
Let me try the code, and I will inform you, tomorrow.

Again, thanks for everything.

Regards,
Prima - Indonesia