Help to Optimize Macro Code for Faster Performance

[Guna13]

Hello everyone,

I have been learning a lot from this amazing forum and have come across many short codes and new techniques. Recently, I created a macro code for Team Entry Preparation. However, I noticed that the code takes more than 1 hour to run when dealing with a large dataset. I believe this is because I am using normal classic code instead of faster or array-level code.

I am reaching out to the experts here to see if anyone could kindly take a look at my code and help me recreate it in a shorter and more efficient version. This optimization would grea

Sub DataTranspose_Optimized_089()

    Dim wsSource As Worksheet, wsSummary As Worksheet
    Dim lastRow As Long, destRow As Long
    Dim dataRange As Range, cell As Range
    Dim dataArray() As Variant
    Dim filterCriteria As String
    Dim netSalaryColumn As Long


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.DisplayStatusBar = True
Application.CommandBars("Formula Bar").Enabled = True

   Dim wsName As String
    wsName = "Financial Account Codes"
    On Error Resume Next
        If Evaluate("ISREF('" & wsName & "_Temp'!A1)") Then
            Sheets(wsName & "_Temp").Cells.Copy Destination:=Sheets(wsName).Cells
            Sheets(wsName & "_Temp").Delete
        End If
    On Error GoTo 0
    
    Sheets(wsName).Copy After:=Sheets(wsName)
    ActiveSheet.Name = wsName & "_Temp"

    On Error Resume Next
       Sheets("Pay Summary").Delete
    On Error GoTo 0

Sheets("Source Data").Copy After:=Sheets("Source Data")
ActiveSheet.Name = "Pay Summary"
    
    Set FinAccCodes = ThisWorkbook.Sheets("Financial Account Codes")
    
     With FinAccCodes
        .Copy After:=.Parent.Sheets(.Index)
        ActiveSheet.Name = "Fin_Acc_Codes_Temp"
        Set filteredSheet = ActiveSheet
        .AutoFilterMode = False
        
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("A1:A" & lastRow).AutoFilter Field:=1, Criteria1:="<>089"
        .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .AutoFilterMode = False
    End With


Dim R As Range, Vin As Variant, Vrw As Variant, Vout As Variant, i As Long, NxRw As Long
Set Wk = ThisWorkbook.Sheets("WS")
Set srk = ThisWorkbook.Sheets("Pay Summary")
Set Src = ThisWorkbook.Sheets("Source Data")

timetaken = Now()

For Each ws In ActiveWorkbook.Worksheets
If ws.AutoFilterMode = True Then
ws.AutoFilterMode = False
End If
Next ws



With Src
        lastRowSource = .Cells(.Rows.Count, "M").End(xlUp).Row
        lastColSource = .Cells(1, .Columns.Count).End(xlToLeft).Column
        .AutoFilterMode = False
        .Range("A1", .Cells(lastRowSource, lastColSource)).AutoFilter Field:=13, Criteria1:="*H1A*"
        .UsedRange.SpecialCells(xlCellTypeVisible).Copy srk.Range("A1")
        .AutoFilterMode = False
End With

    Dim arr As Variant
    With srk.Range("M1", srk.Cells(srk.Rows.Count, "M").End(xlUp))
        .Value = Application.Trim(.Value)
    End With
lastCol = srk.Cells(1, Columns.Count).End(xlToLeft).Column
ColumnLetter = Split(srk.Cells(1, lastCol).Address, "$")(1)

 If Not srk Is Nothing Then
        
        With srk.Rows(1)
            Dim netSalaryCell As Range
            Set netSalaryCell = .Find("NET SALARY", , , xlWhole)
            If Not netSalaryCell Is Nothing Then
                netSalaryColumn = netSalaryCell.Column
                Dim lastColumn As Long
                lastColumn = srk.Cells(1, srk.Columns.Count).End(xlToLeft).Column
                If lastColumn > netSalaryColumn Then
                    srk.Range(srk.Cells(1, netSalaryColumn + 1), srk.Cells(1, lastColumn)).EntireColumn.Delete
                End If
            End If
        End With
    Else
        MsgBox "Sheet 'Pay Summary' not found.", vbExclamation
    End If

Wk.UsedRange.Clear
Enty.UsedRange.Offset(1).Clear

Wk.Range("A1:A" & lastCol).Value = WorksheetFunction.Transpose(srk.Range("A1", ColumnLetter & lastCol))

Set R = srk.Range("A1").CurrentRegion
Vin = R.Value
ReDim Vout(1 To UBound(Vin, 1), 1 To 1)
lchkw = srk.Cells(Rows.Count, "A").End(xlUp).Row

For i = 2 To UBound(Vin)
If i Mod 1 <> 1 Then
Vrw = R.Rows(i).Value
Vout = Application.Transpose(Vrw)
NxRw = IIf(IsEmpty(Wk.Range("DY1")), 1, Wk.Range("DY" & Rows.Count).End(xlUp).Row + 1)
Wk.Range("B" & NxRw).Resize(UBound(Vrw, 2), 1).Value = Vout
Second_Step_AI
End If

Call UpdateJVEntries
'Call Demo1bb8
Application.StatusBar = "Processing row " & i & " of " & lchkw & " - Running Time: " & Format(Now - timetaken, "hh:mm:ss")
Wk.UsedRange.Clear

Wk.Range("A1:A" & lastCol).Value = WorksheetFunction.Transpose(srk.Range("A1", ColumnLetter & lastCol))

Next i

Call Get_DR_CR_Total_AI

timetaken = Now() - timetaken

With Enty.Cells.Font
    .Name = "Century Gothic"
    .Size = 9
End With
ActiveWindow.DisplayGridlines = False

Trg.UsedRange.Clear

MsgBox "Completed JV Booking !!! " & vbNewLine & vbNewLine & " Entry Validation Value -" & Enty.Range("M4").Value & vbNewLine & vbNewLine & " Time Taken is - " & Format(timetaken, "HH:MM:SS"), vbInformation, "Hi " & Application.UserName

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.DisplayStatusBar = False
Application.DisplayFormulaBar = initialFormulaBarState

End Sub
Sub Second_Step_AI()
Dim ltc As Integer, ColumnNumber As Integer, lastRow As Long
Dim EmpID As String, CCFValue As String
Dim Prj As Worksheet, FAC As Worksheet
Dim FinAccCodes As Worksheet
Dim lastRowTrg As Long
Dim lastRowFinAccCodes As Long
Dim i As Long, j As Long
  
Trg.Activate
EmpID = Trg.Range("B3").Value
Trg.Rows("1:11").Delete
Trg.Rows("2:14").Delete
Call Del_Blank_and_0

Set Prj = ThisWorkbook.Sheets("Allocation")
'Set FAC = ThisWorkbook.Sheets("Financial Account Codes")
Trg.Range("C1:E1").Value = Array("Type", "DR", "CR")

ColumnNumber = Prj.Range("A1").SpecialCells(xlCellTypeLastCell).Column - 1
Prj.Range("F1", Prj.Cells(1, ColumnNumber)).Copy Trg.Range("F1")
Application.CutCopyMode = False

lastRowTrg = Trg.Cells(Trg.Rows.Count, "A").End(xlUp).Row

CCFValue = Left(Trg.Range("B1"), 1)

With Trg
    .Range("C2").FormulaR1C1 = "=VLOOKUP(RC[-2],'Financial Account Codes'!C[-1]:C,2,0)"
    If CCFValue = 1 Then
        .Range("D2").FormulaR1C1 = "=VLOOKUP(RC[-3],'Financial Account Codes'!C[-2]:C[2],5,0)"
        .Range("E2").FormulaR1C1 = "=VLOOKUP(RC[-4],'Financial Account Codes'!C[-3]:C[5],9,0)"
    Else
        .Range("D2").FormulaR1C1 = "=VLOOKUP(RC[-3],'Financial Account Codes'!C[-2]:C[1],4,0)"
        .Range("E2").FormulaR1C1 = "=VLOOKUP(RC[-4],'Financial Account Codes'!C[-3]:C[4],8,0)"
    End If
End With


lastRow = Trg.Range("A" & Rows.Count).End(xlUp).Row
For Each rng In Trg.Range("C2:E2")
    rng.AutoFill Destination:=rng.Resize(lastRow - 1), Type:=xlFillDefault
    rng.Resize(lastRow - 1).Value = rng.Resize(lastRow - 1).Value
Next rng


With Trg.UsedRange
    .AutoFilter Field:=3, Criteria1:="#N/A"
    If .Row + .Rows.Count > 2 Then
        .Columns(2).Offset(1).SpecialCells(xlCellTypeVisible).Delete
    End If
    .AutoFilter
End With

lastRow = Trg.Range("A" & Rows.Count).End(xlUp).Row

    Application.ScreenUpdating = False
    With Trg.Range("A1:E" & lastRow)
        .AutoFilter Field:=4, Criteria1:=0 ' Column D
        .AutoFilter Field:=5, Criteria1:=0 ' Column E
        On Error Resume Next
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        On Error GoTo 0
        End With
 Trg.AutoFilterMode = False


Trg.Rows(2).EntireRow.Insert

Alloc.Activate

With Alloc
    Lcm = .Cells(1, Columns.Count).End(xlToLeft).Column - 1
    R = .Columns("A:A").Find(what:=EmpID).Row
   Set rng = .Range(.Cells(R, 5), .Cells(R, Lcm))
End With
Trg.Activate

rng.Copy Trg.Range("E2")
Trg.Range("B2").Value = EmpID

Application.CutCopyMode = False

Lllc = Trg.Cells(1, Columns.Count).End(xlToLeft).Column - 5
Lll = Trg.Cells(1, Columns.Count).End(xlToLeft).Column
lr = Trg.Range("a" & Rows.Count).End(xlUp).Row

ColumnNumber = Lll
NColumnNumber = Lll + 1
Numfcn = Lll + 2
'Convert To Column Letter
Crm = Split(Cells(1, ColumnNumber).Address, "$")(1)
Crmc = Split(Cells(1, NColumnNumber).Address, "$")(1)
Crmg = Split(Cells(1, Numfcn).Address, "$")(1)


Trg.Range(Cells(3, 6), Cells(lr, Lllc + 5)).FormulaR1C1 = "=RC2/1*R2C"
'For R = 3 To lr
 '       a = Cells.Range("B" & R)
  '  Trg.Cells(R, Crmc) = WorksheetFunction.Sum(Range("F" & R & ":Crm" & R))
   ' b = Trg.Cells(R, Crmc)
    'Trg.Cells(R, Crmc).Offset(, 1).Value = a - b
'Next
Range("F3:" & Crmg & Cells(Rows.Count, "A").End(xlUp).Row).NumberFormat = "#,##0.00"
End Sub

Sub Del_Blank_and_0()
  Dim Trg As Worksheet
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long
  
  Set Trg = ActiveSheet '<- Perhaps you have a worksheet name instead?
  With Trg
    nc = .Cells.Find(what:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    a = .Range("B2", .Range("B" & Rows.Count).End(xlUp)).Value
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      If a(i, 1) = "" Or a(i, 1) = 0 Then
        b(i, 1) = 1
        k = k + 1
      End If
    Next i
    If k > 0 Then
      Application.ScreenUpdating = False
      With .Range("A2").Resize(UBound(a), nc)
        .Columns(nc).Value = b
        .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
        .Resize(k).EntireRow.Delete
      End With
      End If
  End With
End Sub
Sub Get_DR_CR_Total_AI()
Enty.Range("L2").Value = "Dr"
Enty.Range("L3").Value = "Cr"
Enty.Range("L4").Value = "Validation"
Enty.Range("M2:M3").FormulaR1C1 = "=SUMIF(C[-4],RC[-1],C[-5])"
Enty.Range("M4").FormulaR1C1 = "=R[-2]C-R[-1]C"
mgr = Enty.Range("M4").Value
Enty.Range("m4").Interior.Color = IIf(mgr > 0, vbRed, vbGreen)
End Sub

Sub Get_DR_CR_Total()

    Enty.Range("L2").Value = "Dr"
    Enty.Range("L3").Value = "Cr"
    Enty.Range("L4").Value = "Validation"

    Enty.Range("M2").FormulaR1C1 = "=SUMIF(C[-4],RC[-1],C[-5])"
    Enty.Range("M3").FormulaR1C1 = "=SUMIF(C[-4],RC[-1],C[-5])"
    Enty.Range("M4").FormulaR1C1 = "=R[-2]C-R[-1]C"
    
     mgr = Enty.Range("M4").Value
    
        If mgr > 0 Then
            Enty.Range("m4").Interior.Color = vbRed
        Else
            Enty.Range("m4").Interior.Color = vbGreen
        
        End If
End Sub
Sub Zero_Value_Entry_sheet()

  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long
  
  Enty.Activate
  
  Set Miyaa = ActiveSheet '<- Perhaps you have a worksheet name instead?
  With Miyaa
    nc = .Cells.Find(what:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    a = .Range("H2", .Range("H" & Rows.Count).End(xlUp)).Value
    ReDim h(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      If a(i, 1) = "" Or a(i, 1) = 0 Then
        h(i, 1) = 1
        k = k + 1
      End If
    Next i
    If k > 0 Then
      Application.ScreenUpdating = False
      With .Range("A2").Resize(UBound(a), nc)
        .Columns(nc).Value = h
        .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
        .Resize(k).EntireRow.Delete
      End With
      Application.ScreenUpdating = True
    End If
  End With

End Sub

Sub Delete_Project_Code_for_Finc()
    Dim columnsToDelete As Variant ' Array to store column names to keep
    Dim colName As Variant ' Variable to loop through the array
    Dim col As Long ' Variable to store column index
    Dim lastCol As Long ' Variable to store the index of the last column
    
    columnsToDelete = Array("273501", "TDN001") ' Add more column names if needed
    
    lastCol = Trg.Cells(1, Trg.Columns.Count).End(xlToLeft).Column
    
    Dim columnsToDeleteRange As Range
    Set columnsToDeleteRange = Nothing
    
    ' Loop through all columns from F to the last column
    For col = Trg.Columns("F").Column To lastCol
        ' Check if the column header is not in the columnsToDelete array
        If IsError(Application.Match(Trg.Cells(1, col).Value, columnsToDelete, 0)) Then
            If columnsToDeleteRange Is Nothing Then
                Set columnsToDeleteRange = Trg.Columns(col)
            Else
                Set columnsToDeleteRange = Union(columnsToDeleteRange, Trg.Columns(col))
            End If
        End If
    Next col
    
    ' Delete all the found columns in one go
    If Not columnsToDeleteRange Is Nothing Then
        columnsToDeleteRange.EntireColumn.Delete
    End If
End Sub
Sub UpdateJVEntries()
    
   ' Delete_Project_Code_for_Finc
    
    Dim lastRow As Long
    Dim lastColumn As Long
    
        Set ws = ThisWorkbook.Sheets("WS")
      '  Set jvSheet = ThisWorkbook.Sheets("JV")
      Call DeleteEmptyProjectColumns
    lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    lastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    
    ws.Range("A2", ws.Cells(lastRow, lastColumn)).Value = ws.Range("A2", ws.Cells(lastRow, lastColumn)).Value
  ws.Rows("2:2").Delete Shift:=xlUp
    lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
   ws.Columns("E:E").Insert Shift:=xlToRight
    ws.Range("E2:E" & lastRow).Value = "DR"
    
    ' Copy the first set of records and paste them below the existing records
    Range("A2", Cells(lastRow, lastColumn + 1)).Copy Range("A" & lastRow + 1)
    
    ' Copy the CR ledger account values and paste them in the new "DR" ledger account column for the second set of records
    Range("F2:F" & lastRow).Copy Range("D" & lastRow + 1 & ":D" & lastRow + lastRow - 1)
    
    ' Update the "CR" values in the second set of records
    Range("E" & lastRow + 1 & ":E" & lastRow + lastRow - 1).Value = "CR"
    
    ' Delete the temporary column used for copying the second set of records
    Columns("F:F").Delete Shift:=xlToLeft
    
lastRow = Cells(Rows.Count, 1).End(xlUp).Row ' Update last row after adding new rows
Dim i As Long

ws.Range("D1:D" & lastRow).AutoFilter Field:=1, Criteria1:=0
On Error Resume Next
    Set rngToDelete = ws.Range("D2:D" & lastRow).SpecialCells(xlCellTypeVisible)
    If Not rngToDelete Is Nothing Then
        rngToDelete.EntireRow.Delete
End If
On Error GoTo 0
ws.AutoFilterMode = False
    
Range("E1").Value = "Dr/Cr"
Call CopyToJVSheet1

lastRow = ThisWorkbook.Sheets("JV").Cells(Rows.Count, 1).End(xlUp).Row ' Update last row after adding new rows
Dim xi As Long


Dim jvSheet As Worksheet
Set jvSheet = ThisWorkbook.Sheets("JV")

With jvSheet
    lastRow = .Cells(.Rows.Count, "H").End(xlUp).Row
    .Range("H1:H" & lastRow).AutoFilter Field:=1, Criteria1:=0
    If Application.WorksheetFunction.Subtotal(103, .Columns("H:H")) > 1 Then
        .Range("H2:H" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    End If
    .AutoFilterMode = False
End With
End Sub
Sub CopyToJVSheet1()
    Dim wsLastRow As Long
    Dim wsLastCol As Long
    Dim jvLastRow As Long
    Dim ws As Worksheet
    Dim jvSheet As Worksheet
    Dim dataRange As Range
    Dim Amt() As Variant, Lg() As Variant, DC() As Variant, CC() As Variant
    
    Set ws = ThisWorkbook.Sheets("WS")
    Set jvSheet = ThisWorkbook.Sheets("JV")
    Set dimSheet = ThisWorkbook.Sheets("Dimension Summary")
  
    wsLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
  wsLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    
    If wsLastCol = 6 Then
    searchValue = ws.Range("F1").Value
    Set summaryRange = dimSheet.Range("B:B")
    Set foundCell = summaryRange.Find(what:=searchValue, LookIn:=xlValues, LookAt:=xlWhole)
    
    dimValue1 = foundCell.Offset(0, 1).Value
    dimValue2 = foundCell.Offset(0, 2).Value
    dimValue4 = foundCell.Offset(0, 3).Value
    dimValue5 = foundCell.Offset(0, 4).Value
    
    Dim firstDigit As Integer
       Dim fs As Range
        Dim AM As Range

        Set fs = ws.Range("F2:F" & wsLastRow)
        Set DCe = ws.Range("E2:E" & wsLastRow)
        Set Lgd = ws.Range("D2:D" & wsLastRow)
        Set DM3 = ws.Range("B1")

        jvLastRow = jvSheet.Cells(jvSheet.Rows.Count, "I").End(xlUp).Row
        R = jvLastRow + 1
        
        jvSheet.Range("I" & jvLastRow + 1).Resize(fs.Rows.Count, 1).Value = DCe.Value
        jvSheet.Range("H" & jvLastRow + 1).Resize(fs.Rows.Count, 1).Value = fs.Value
        jvSheet.Range("A" & jvLastRow + 1).Resize(fs.Rows.Count, 1).Value = Lgd.Value
        jvSheet.Range("D" & jvLastRow + 1).Resize(fs.Rows.Count, 1).Value = DM3.Value
        
   For Each cell In jvSheet.Range("A" & R & ":A" & jvSheet.Cells(jvSheet.Rows.Count, "I").End(xlUp).Row)
   firstDigit = Val(Left(cell.Value, 1))
    If firstDigit > 2 Then
            cell.Offset(0, 1).Formula = dimValue1 ' Apply the formula when first digit > 2
            cell.Offset(0, 2).Formula = dimValue2
            cell.Offset(0, 4).Formula = dimValue4
            cell.Offset(0, 5).Formula = dimValue5
        Else
            cell.Offset(0, 1).Value = "" ' Leave the cell blank when first digit <= 2
            cell.Offset(0, 4).Formula = dimValue4
            cell.Offset(0, 5).Formula = dimValue5
        End If
    Next cell
        
      '  jvSheet.Range("B2:B" & jvSheet.Cells(jvSheet.Rows.Count, "A").End(xlUp).Row).Value = dimValue1
       ' jvSheet.Range("C2:C" & jvSheet.Cells(jvSheet.Rows.Count, "A").End(xlUp).Row).Value = dimValue2
        'jvSheet.Range("E2:E" & jvSheet.Cells(jvSheet.Rows.Count, "A").End(xlUp).Row).Value = dimValue4
        'jvSheet.Range("F2:F" & jvSheet.Cells(jvSheet.Rows.Count, "A").End(xlUp).Row).Value = dimValue5
  Else
    
    ' Find the last row in the JV sheet
    jvLastRow = Sheets("JV").Cells(Rows.Count, 1).End(xlUp).Row
    
    ' Get the values from the DIM sheet
    Dim dim1Values As Variant
    Dim dim2Values As Variant
    Dim dim3Values As Variant
    Dim dim4Values As Variant
    Dim Dim1V As Variant
    
    ' Get the value from cell B1 in the WS sheet to update in the JV sheet
    Dim b1Value As String
    b1Value = Sheets("WS").Cells(1, "B").Value
    
   ' dim1Values = Range("B2")
    ' Loop through each row in the WS sheet, starting from row 2
    For i = 2 To wsLastRow
        ' Get the ledger account from column D
        Dim ledgerAccount As String
            
        ledgerAccount = Sheets("WS").Cells(i, "D").Value
        Dim1V = dimSheet.Range("B2").Value
        Dim2V = dimSheet.Range("C2").Value
        Dim4V = dimSheet.Range("D2").Value
        Dim5V = dimSheet.Range("E2").Value
        
        ' Check if the ledger account starts with 1 or 2
        If Left(ledgerAccount, 1) = "1" Or Left(ledgerAccount, 1) = "2" Then
            ' Copy the value from cell B1 and paste it in the JV sheet column D
            Sheets("JV").Cells(jvLastRow + 1, "D").Value = b1Value
            ' Update the ledger account, "A" column value and "I" column value in the JV sheet
            Sheets("JV").Cells(jvLastRow + 1, "A").Value = ledgerAccount
            
           ' Sheets("JV").Cells(jvLastRow + 1, "B").Value = Dim1V
            'Sheets("JV").Cells(jvLastRow + 1, "C").Value = Dim2V
            Sheets("JV").Cells(jvLastRow + 1, "E").Value = Dim4V
            Sheets("JV").Cells(jvLastRow + 1, "F").Value = Dim5V
            Sheets("JV").Cells(jvLastRow + 1, "D").Value = b1Value
            Sheets("JV").Cells(jvLastRow + 1, "H").Value = Sheets("WS").Cells(i, "B").Value
            Sheets("JV").Cells(jvLastRow + 1, "I").Value = ws.Cells(i, "E").Value
            ' Update the last row in the JV sheet
            jvLastRow = jvLastRow + 1
        Else
            ' Get the salary classification amounts from column F to the last dynamic column
         Dim amounts As Variant
            
            amounts = Sheets("WS").Range(Sheets("WS").Cells(i, "F"), Sheets("WS").Cells(i, wsLastCol)).Value
            
            ' Transpose the amounts and copy them to the JV sheet
            Sheets("JV").Range("H" & jvLastRow + 1).Resize(UBound(amounts, 2)).Value = Application.Transpose(amounts)
            Proct = ws.Range(ws.Cells(1, "F"), ws.Cells(1, ws.Cells(1, Columns.Count).End(xlToLeft).Column)).Value


' Update values in column B based on VLOOKUP from "Dim Summary" sheet
Dim dimSummary As Worksheet
Set dimSummary = ThisWorkbook.Sheets("Dimension Summary") ' Change "Dim Summary" to your actual worksheet name

For j = 1 To UBound(Proct, 2)
    Dim lookupValue As Variant
    lookupValue = Proct(1, j)
    
    Dim resultValue As Variant
    
    resultValue = Application.VLookup(lookupValue, dimSummary.Range("B:C"), 2, False)
    resultValue1 = Application.VLookup(lookupValue, dimSummary.Range("B:D"), 3, False)
    resultValue2 = Application.VLookup(lookupValue, dimSummary.Range("B:E"), 4, False)
    resultValue3 = Application.VLookup(lookupValue, dimSummary.Range("B:F"), 5, False)
    
    
    If Not IsError(resultValue) Then
        ThisWorkbook.Sheets("JV").Cells(jvLastRow + j, "B").Value = resultValue
        ThisWorkbook.Sheets("JV").Cells(jvLastRow + j, "C").Value = resultValue1
        ThisWorkbook.Sheets("JV").Cells(jvLastRow + j, "E").Value = resultValue2
        ThisWorkbook.Sheets("JV").Cells(jvLastRow + j, "F").Value = resultValue3
        
        
    Else
        ' Handle the case where the lookup value was not found
        ThisWorkbook.Sheets("JV").Cells(jvLastRow + j, "B").Value = "Not Found"
    End If
Next j
                    
       ' Call DimFull
            ' Update the ledger account in column A for each line
            'Dim j As Long
            For j = 0 To UBound(amounts, 2)
                Sheets("JV").Cells(jvLastRow + j + 1, "A").Value = ledgerAccount
                Sheets("JV").Cells(jvLastRow + j + 1, "D").Value = b1Value
               ' Sheets("JV").Cells(jvLastRow + 1, "B").Value = dim1Values
                Sheets("JV").Cells(jvLastRow + j + 1, "I").Value = ws.Cells(i, "E").Value
            Next j
            ' Update the last row in the JV sheet
            jvLastRow = jvLastRow + UBound(amounts, 2)
        End If
    Next i
End If
End Sub
Sub DeleteEmptyProjectColumns()
    Dim ws As Worksheet
    Dim rng As Range
    Dim col As Range
    Dim lastColumn As Long

    Set ws = ThisWorkbook.Sheets("WS")
    lastColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    Set rng = ws.Range(ws.Cells(1, 6), ws.Cells(1, lastColumn))

    For i = lastColumn To 6 Step -1
        If ws.Cells(2, i).Value = "" Or Not IsNumeric(ws.Cells(2, i).Value) Then
            ws.Columns(i).Delete
        End If
    Next i
End Sub

Also asked here Seeking Help to Optimize Macro Code for Faster Performance