Need Help Deleting Empty Columns Based on Condition in Excel Spreadsheet by VBA code

[Guna13]

Hi All,

I need assistance on how to efficiently delete blank and empty columns based on a condition in the second row, starting from "F" column to the last column. I have updated the entire project code information in columns F1 to the last column, totaling more than 150+ columns. In the second row, if a project is used, it will have a corresponding number proportion like 1 or 0.50, 0.30, etc., but the sum of these values should not exceed 1 (100%).

Can someone please guide me on how to find and delete the empty columns that do not meet this condition? this below code is running. but just taking time. ( because this is repeated process for more than 6000+ Employee. so my performance is down.

Thank you for your help.

Sub DeleteEmptyProjectColumns_New()
    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

Emample screen shot.

 

[Peter_SSs]

In the second row, if a project is used, it will have a corresponding number proportion like 1 or 0.50, 0.30, etc.

So, in your image every column F:S would get deleted since nothing in row 2 - is that correct?

Does column A allow us to determine the last row of data in the worksheet?

 

[Guna13]

So, in your image every column F:S would get deleted since nothing in row 2 - is that correct?

Does column A allow us to determine the last row of data in the worksheet?

Dear Peters SS.

I apologize for the confusion in my previous Screen shot. Here is the actual screenshot. The sheet name is called WS. I need to check from column "F" to the last dynamic column, and wherever there is a number less than 1 in the second row (e.g., 0.05, 0.095, or 1.00), I will keep those columns. The rest of the entire columns should be deleted in a faster way. (From column "F" to the till last column ***).

 

[Peter_SSs]

Try this with a copy of your workbook.

Sub Delete_Unwanted_Columns()
  Dim ws As Worksheet
  Dim a As Variant, b As Variant
  Dim nr As Long, lc As Long, i As Long, k As Long
  
  Set ws = ThisWorkbook.Sheets("WS")
  With ws
    nr = .Range("A" & Rows.Count).End(xlUp).Row + 1
    lc = .Cells(1, Columns.Count).End(xlToLeft).Column
    a = .Range("F2", .Cells(2, lc)).Value
    ReDim b(1 To 1, 1 To UBound(a, 2))
    For i = 1 To UBound(a, 2)
      If Len(a(1, i)) = 0 Or Not IsNumeric(a(1, i)) Then
        b(1, i) = 1
        k = k + 1
      End If
    Next i
    If k > 0 Then
      Application.ScreenUpdating = False
      With .Range("F1").Resize(nr, lc - 5)
        .Rows(nr).Value = b
        .Sort Key1:=.Rows(nr), Order1:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight
        .Resize(, k).EntireColumn.Delete
      End With
      Application.ScreenUpdating = True
    End If
  End With
End Sub

 

[Guna13]

Try this with a copy of your workbook.

Sub Delete_Unwanted_Columns()
  Dim ws As Worksheet
  Dim a As Variant, b As Variant
  Dim nr As Long, lc As Long, i As Long, k As Long
 
  Set ws = ThisWorkbook.Sheets("WS")
  With ws
    nr = .Range("A" & Rows.Count).End(xlUp).Row + 1
    lc = .Cells(1, Columns.Count).End(xlToLeft).Column
    a = .Range("F2", .Cells(2, lc)).Value
    ReDim b(1 To 1, 1 To UBound(a, 2))
    For i = 1 To UBound(a, 2)
      If Len(a(1, i)) = 0 Or Not IsNumeric(a(1, i)) Then
        b(1, i) = 1
        k = k + 1
      End If
    Next i
    If k > 0 Then
      Application.ScreenUpdating = False
      With .Range("F1").Resize(nr, lc - 5)
        .Rows(nr).Value = b
        .Sort Key1:=.Rows(nr), Order1:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight
        .Resize(, k).EntireColumn.Delete
      End With
      Application.ScreenUpdating = True
    End If
  End With
End Sub

I am thrilled to see how well the previous code performed, deleting around 100+ columns within a blink of an eye! Your assistance and support have been simply wonderful, and more thankful Sir.

I am, however, facing a significant bottleneck that could use your expert advice. When dealing with large datasets, particularly those exceeding 7500+ lines, the process is painfully slow, often taking up to 2 hours.

I am working across three sheets - WS, JV, and Allocation. The WS sheet houses the booking info which is updated in the JV Sheet. Moreover, I am also pulling in Dimension information from the Dimension sheet based on the Project info in the WS Sheet (starting at "F" column, for either single or multiple projects). All these steps have been translated into a code but it's slow and less efficient, using standard copy and paste methods.

Do you have any suggestions on how I could restructure this? Could arrays or the UBound function potentially be the solution? Any guidance on how to optimize this further would be greatly appreciated. Thank you for your time and consideration.

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 dim1Values As Variant
    Dim dim2Values As Variant
    Dim dim3Values As Variant
    Dim dim4Values As Variant
    Dim Dim1V As Variant
    Dim ledgerAccount As String
    Dim b1Value As String
    Dim Amt() As Variant, Lg() As Variant, DC() As Variant, CC() As Variant
    Dim amounts As Variant
    Dim firstDigit As Long
    Dim fs As Range
    Dim AM As Range

   
    Set ws = ThisWorkbook.Sheets("WS")
    Set jvSheet = ThisWorkbook.Sheets("JV")
    Set dimSheet = ThisWorkbook.Sheets("Dimension Summary")
    Set dimSummary = 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 foundCell = dimSheet.Range("B:B").Find(what:=searchValue, LookIn:=xlValues, LookAt:=xlWhole)
       
        Dim dimValues() As Variant
        dimValues = foundCell.Offset(0, 1).Resize(1, 4).Value
       
        jvLastRow = jvSheet.Cells(jvSheet.Rows.Count, "I").End(xlUp).Row
        Dim startRow As Long: startRow = jvLastRow + 1
       
        ' Copying data in one shot to avoid loops
        jvSheet.Range("I" & startRow).Resize(wsLastRow - 1, 1).Value = ws.Range("E2:E" & wsLastRow).Value
        jvSheet.Range("H" & startRow).Resize(wsLastRow - 1, 1).Value = ws.Range("F2:F" & wsLastRow).Value
        jvSheet.Range("A" & startRow).Resize(wsLastRow - 1, 1).Value = ws.Range("D2:D" & wsLastRow).Value
        jvSheet.Range("J" & startRow).Resize(wsLastRow - 1, 1).Value = EmpID
       
        jvSheet.Range("D" & startRow).Resize(wsLastRow - 1, 1).Value = ws.Range("B1").Value
       
    For Each cell In jvSheet.Range("A" & jvLastRow + 1 & ":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 = dimValues(1, 1) ' Apply the formula when first digit > 2
                cell.Offset(0, 2).Formula = dimValues(1, 2)
                cell.Offset(0, 4).Formula = dimValues(1, 3)
                cell.Offset(0, 5).Formula = dimValues(1, 4)
                cell.Offset(0, 9).Formula = EmpID
               
        Else
              cell.Offset(0, 1).Value = "" ' Leave the cell blank when first digit <= 2
            cell.Offset(0, 4).Formula = dimValues(1, 3)
            cell.Offset(0, 5).Formula = dimValues(1, 4)
            cell.Offset(0, 9).Formula = EmpID
            End If
    Next cell

Else
   
    jvLastRow = Sheets("JV").Cells(Rows.Count, 1).End(xlUp).Row
   
    b1Value = Sheets("WS").Cells(1, "B").Value
   
    For i = 2 To wsLastRow
           
        ledgerAccount = Sheets("WS").Cells(i, "D").Value
        Dim4V = dimSheet.Range("D2").Value
        Dim5V = dimSheet.Range("E2").Value
       
        If Left(ledgerAccount, 1) = "1" Or Left(ledgerAccount, 1) = "2" Then
            Sheets("JV").Cells(jvLastRow + 1, "D").Value = b1Value
            Sheets("JV").Cells(jvLastRow + 1, "A").Value = ledgerAccount
            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
            Sheets("JV").Cells(jvLastRow + 1, "J").Value = EmpID
           
            jvLastRow = jvLastRow + 1
        Else
           
            amounts = Sheets("WS").Range(Sheets("WS").Cells(i, "F"), Sheets("WS").Cells(i, wsLastCol)).Value
            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
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
        ThisWorkbook.Sheets("JV").Cells(jvLastRow + j, "J").Value = EmpID
       
    Else
        ThisWorkbook.Sheets("JV").Cells(jvLastRow + j, "B").Value = "Not Found"
    End If
Next j
                   
            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 + j + 1, "I").Value = ws.Cells(i, "E").Value
                Sheets("JV").Cells(jvLastRow + j + 1, "J").Value = EmpID
               
            Next j
            jvLastRow = jvLastRow + UBound(amounts, 2)
        End If
    Next i
End If
End Sub

 

[Peter_SSs]

Glad the previous code worked well for you. Thanks for letting us know.

When posting vba code in the forum don't forget to use the available code tags. I have added the tags for you this time.

Could we have some small but representative sample data with XL2BB for each of the relevant sheets so we can copy for testing if required, & explain in relation to that sample data what the code is doing or needs to do?

 

[Guna13]

Glad the previous code worked well for you. Thanks for letting us know.

When posting vba code in the forum don't forget to use the available code tags. I have added the tags for you this time.

Could we have some small but representative sample data with XL2BB for each of the relevant sheets so we can copy for testing if required, & explain in relation to that sample data what the code is doing or needs to do?

Hi Peter, as per your advice. i have installed tha xl2bb Add-Ins and take the mini-sheet clipboard and save it here. if i am wrong, kindly guide me. totally three sheet is there.
First Sheet name is called WS

Only community Purpose.xlsm
	A	B	C	D	E	F	G
1	Cost Center	1001	Type	DR	Dr/Cr	AVT001	BAT016
2	BASIC SALARY	1500	E	450100	DR	750.00	750.00
3	NIGHT SHIFT ALLOWANCE(12 HR)	120	E	450101	DR	60.00	60.00
4	MORNING SHIFT ALLOWANCE	36	E	450101	DR	18.00	18.00
5	HRD LEVY	11	0	450313	DR	5.50	5.50
6	EMPLOYER EIS	2.5	E	450313	DR	1.25	1.25
7	EMPLOYER EPF	167	0	450312	DR	83.50	83.50
8	EMPLOYER SOCSO	21.85	0	450313	DR	10.93	10.93
9	MID MONTH PAYMENT DEDUCTION	1500	D	217000	CR	1,500.00	1,500.00
10	ABSENT	120	D	450100	CR	60.00	60.00
11	UNPAID LEAVES	36	D	450100	CR	18.00	18.00
12	HRD LEVY	11	0	220002	CR	11.00	11.00
13	EMPLOYER EIS	2.5	D	220005	CR	2.50	2.50
14	EMPLOYEE EIS	167	D	220005	CR	167.00	167.00
15	EMPLOYER EPF	21.85	0	220003	CR	21.85	21.85
WS

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
G1	Cell Value	duplicates	text	NO
G1	Cell Value	duplicates	text	NO

Second sheet name is called Dimension Summary

Only community Purpose.xlsm
	A	B	C	D	E	F
1	Baan Code	Dimension Code	Dimension1	Dimension2	Dimension4	Dimension5
2	27	671203	sdfsf	sdfdsf	sdf	sdf
3	27	671207	sdfsf	sdfdsf	999999	sdf
4	27	999999	sdfsf	sf	safd	adsf
5	27	AVT001	sdfsf	asfd	dsfa	asf
6	27	BAT016	dsf	asfd	MCSPEN	asfd
7	27	CHN217	sfd	saf	sadf	asfd
8	27	CHN852	sdfsf	saf	MCSPEN	sadf
9	27	CHN868	sdfsf	saf	asf	safd
10	27	CNE001	sfd	asdf	d	asfd
11	27	CR5370	dsfs	saf	MCSPEN	asf
12	27	CR5377	fds	dasf	dsafd	safd
13	27	CR5379	fds	asfd	asfd	safd
14	27	CR5384	fds	safd	sdf	asf
15	27	CR5385	fdsf	safd	safd	safd
16	27	CR5386	sdfsf	sdfdsf	sdf	sdf
17	27	CR5388	sdfsf	sdfdsf	999999	sdf
18	27	CR6377	sdfsf	sf	safd	adsf
19	27	CR6378	sdfsf	asfd	dsfa	asf
20	27	CR6380	dsf	asfd	MCSPEN	asfd
21	27	CR6381	sfd	saf	sadf	asfd
22	27	CR6383	sdfsf	saf	MCSPEN	sadf
23	27	CR6384	sdfsf	saf	asf	safd
24	27	CR6386	sfd	asdf	d	asfd
25	27	CR6388	dsfs	saf	MCSPEN	asf
26	27	CR6391	fds	dasf	dsafd	safd
27	27	CR6407	fds	asfd	asfd	safd
28	27	CR6619	fds	safd	sdf	asf
29	27	CR6710	fdsf	safd	safd	safd
30	27	CR6720	sdfsf	sdfdsf	sdf	sdf
31	27	CR6723	sdfsf	sdfdsf	999999	sdf
32	27	CR6802	sdfsf	sf	safd	adsf
33	27	CR6807	sdfsf	asfd	dsfa	asf
34	27	CR6822	dsf	asfd	MCSPEN	asfd
35	27	CR6908	sfd	saf	sadf	asfd
36	27	CR6909	sdfsf	saf	MCSPEN	sadf
37	27	CR8311	sdfsf	saf	asf	safd
38	27	CR8502	sfd	asdf	d	asfd
39	27	CR9302	dsfs	saf	MCSPEN	asf
40	27	CR9303	fds	dasf	dsafd	safd
41	27	CR9868	fds	asfd	asfd	safd
42	27	CR9905	fds	safd	sdf	asf
43	27	CR9914	fdsf	safd	safd	safd
44	27	CR9920	sdfsf	sdfdsf	sdf	sdf
45	27	CR9922	sdfsf	sdfdsf	999999	sdf
46	27	CR9937	sdfsf	sf	safd	adsf
47	27	CR9948	sdfsf	asfd	dsfa	asf
48	27	CR9954	dsf	asfd	MCSPEN	asfd
49	27	CR9964	sfd	saf	sadf	asfd
50	27	CR9971	sdfsf	saf	MCSPEN	sadf
51	27	CR9983	sdfsf	saf	asf	safd
52	27	CR9987	sfd	asdf	d	asfd
53	27	CR9994	dsfs	saf	MCSPEN	asf
54	27	CR9996	fds	dasf	dsafd	safd
55	27	CR9998	fds	asfd	asfd	safd
56	27	CS5306	fds	safd	sdf	asf
57	27	CS9933	fdsf	safd	safd	safd
58	27	DSN335	dsfs	saf	MCSPEN	asf
59	27	DYG001	fds	dasf	dsafd	safd
60	27	ERB003	fds	asfd	asfd	safd
61	27	FMS864	fds	safd	sdf	asf
62	27	FSA157	fdsf	safd	safd	safd
63	27	FSA707	sdfsf	sdfdsf	sdf	sdf
64	27	FSA828	sdfsf	sdfdsf	999999	sdf
65	27	FTP717	sdfsf	sf	safd	adsf
66	27	HK6386	sdfsf	asfd	dsfa	asf
67	27	HK6392	dsf	asfd	MCSPEN	asfd
68	27	HK7150	sfd	saf	sadf	asfd
69	27	HK7272	sdfsf	saf	MCSPEN	sadf
70	27	HK8150	sdfsf	saf	asf	safd
71	27	HK9948	sfd	asdf	d	asfd
72	27	HK9949	dsfs	saf	MCSPEN	asf
73	27	HNW001	fds	dasf	dsafd	safd
74	27	ITL001	fds	asfd	asfd	safd
75	27	JNT001	Guna	Guna	Guna	Guna
76	27	KAL012	fdsf	safd	safd	safd
77	27	MRV001	MRV001	I62501	999999	999999
78	27	NEX063	CRPUSE	999999	MCSPEN	NEX063
79	27	PNG027	CRPUSE	999999	MCSPEN	PNG027
80	27	PNG062	CRPUSE	999999	MCSPEN	PNG062
81	27	PNG089	CRPUSE	999999	MCSPEN	PNG089
82	27	PNG091	CRPUSE	999999	MCSPEN	PNG091
83	27	PNG440	sdfsf	sdfdsf	sdf	sdf
84	27	PSO001	sdfsf	sdfdsf	999999	sdf
85	27	PUN762	sdfsf	sf	safd	adsf
86	27	SHA168	sdfsf	asfd	dsfa	asf
87	27	SKU773	dsf	asfd	MCSPEN	asfd
88	27	SNG886	sfd	saf	sadf	asfd
89	27	TDN002	sdfsf	saf	MCSPEN	sadf
90	27	TEK001	sdfsf	saf	asf	safd
91	27	WUZ898	sfd	asdf	d	asfd
92	27	XRT001	dsfs	saf	MCSPEN	asf
93	27	XRT002	fds	dasf	dsafd	safd
94	27	XRT003	fds	asfd	asfd	safd
95	62	DEXCOM	fds	safd	sdf	asf
96	89	273501	fdsf	safd	safd	safd
97	89	TDN001	fdsf	safd	safd	safd
98	91	MIS001	fdsf	safd	safd	safd
99	27	TDN001	fdsf	safd	safd	safd
Dimension Summary

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
B99	Cell Value	duplicates	text	NO
B99	Cell Value	duplicates	text	NO
B99	Cell Value	duplicates	text	NO
B1:B98,B100:B1048576	Cell Value	duplicates	text	NO
B95:B98,B100:B1048576	Cell Value	duplicates	text	NO
B1:B98	Cell Value	duplicates	text	NO

Thired Sheet Name is called - JV

Only community Purpose.xlsm
	A	B	C	D	E	F	G	H	I	J
1	Ledger account	Dim 1	Dim 2	Dim 3	Dim 4	Dim 5	Currency	Transaction Amount	Dr/Cr	Emp_ID
2	450100	sdfsf	asfd	1001	dsfa	asf		750	DR
3	450100	dsf	asfd	1001	MCSPEN	asfd		750	DR
4	450101	sdfsf	asfd	1001	dsfa	asf		60	DR
5	450101	dsf	asfd	1001	MCSPEN	asfd		60	DR
6	450101	sdfsf	asfd	1001	dsfa	asf		18	DR
7	450101	dsf	asfd	1001	MCSPEN	asfd		18	DR
8	450313	sdfsf	asfd	1001	dsfa	asf		5.5	DR
9	450313	dsf	asfd	1001	MCSPEN	asfd		5.5	DR
10	450313	sdfsf	asfd	1001	dsfa	asf		1.25	DR
11	450313	dsf	asfd	1001	MCSPEN	asfd		1.25	DR
12	450312	sdfsf	asfd	1001	dsfa	asf		83.5	DR
13	450312	dsf	asfd	1001	MCSPEN	asfd		83.5	DR
14	450313	sdfsf	asfd	1001	dsfa	asf		10.925	DR
15	450313	dsf	asfd	1001	MCSPEN	asfd		10.925	DR
16	217000			1001	sdfdsf	sdf		1500	CR
17	450100	sdfsf	asfd	1001	dsfa	asf		60	CR
18	450100	dsf	asfd	1001	MCSPEN	asfd		60	CR
19	450100	sdfsf	asfd	1001	dsfa	asf		18	CR
20	450100	dsf	asfd	1001	MCSPEN	asfd		18	CR
21	220002			1001	sdfdsf	sdf		11	CR
22	220005			1001	sdfdsf	sdf		2.5	CR
23	220005			1001	sdfdsf	sdf		167	CR
24	220003			1001	sdfdsf	sdf		21.85	CR
JV

 

[Peter_SSs]

Thanks for the XL2BB sample data.

However, what about this?

& explain in relation to that sample data what the code is doing or needs to do?

Since I am not familiar with your data, vba code or requirements I am not sure I can help unless I can clearly understand what the code does or needs to do.

 

[Guna13]

Thanks for the XL2BB sample data.

However, what about this?

Since I am not familiar with your data, vba code or requirements I am not sure I can help unless I can clearly understand what the code does or needs to do.

I kindly request your help and support to optimize the code for better performance in my spreadsheet. This specific part of the code is concerning three sheets: WS, JV, and Allocation.

On the WS sheet, the booking information is available, with the Salary Info in column B extending to the last row, the Ledger account information in column D, and the Dr/CR information from column E to the last column. The Employee Engaged Project names and their respective percentages are used to calculate the amounts based on the Salary column (please note that my previous code handles this part, so no need to address it here).

In the dimension Summary sheet, we have maintained the Projected codes related to Dim1, Dim3, Dim4, and Dim5. The unique code for Dim3 is referred from cell B2 in the WS Sheet.

In the JV sheet, I need to update the WS salary information in the appropriate columns for booking purposes, along with the respective Project details obtained from the Dimension Summary sheet.

Currently, my code is running slowly, and I'm unsure how to write a faster code using arrays or Ubound functions for this task.

The condition is that on the WS sheet, I only have six columns to directly transpose the amounts to the JV sheet. If an employee is engaged in multiple projects for more than 1 Like more than 6 column in WS Sheet, I will consider all the project details.

I believe this information is sufficient for you to assist me in optimizing the code. Thank you for your valuable support.

 

[Guna13]

I kindly request your help and support to optimize the code for better performance in my spreadsheet. This specific part of the code is concerning three sheets: WS, JV, and Allocation.

On the WS sheet, the booking information is available, with the Salary Info in column B extending to the last row, the Ledger account information in column D, and the Dr/CR information from column E to the last column. The Employee Engaged Project names and their respective percentages are used to calculate the amounts based on the Salary column (please note that my previous code handles this part, so no need to address it here).

In the dimension Summary sheet, we have maintained the Projected codes related to Dim1, Dim3, Dim4, and Dim5. The unique code for Dim3 is referred from cell B2 in the WS Sheet.

In the JV sheet, I need to update the WS salary information in the appropriate columns for booking purposes, along with the respective Project details obtained from the Dimension Summary sheet.

Currently, my code is running slowly, and I'm unsure how to write a faster code using arrays or Ubound functions for this task.

The condition is that on the WS sheet, I only have six columns to directly transpose the amounts to the JV sheet. If an employee is engaged in multiple projects for more than 1 Like more than 6 column in WS Sheet, I will consider all the project details.

I believe this information is sufficient for you to assist me in optimizing the code. Thank you for your valuable support.

Thanks for the XL2BB sample data.

However, what about this?

Since I am not familiar with your data, vba code or requirements I am not sure I can help unless I can clearly understand what the code does or needs to do.

@Peter_SSs, if my explanation is not clear or not able to understand. please let me know​