Help with format tweaking of existing code (date and text)

[Serafin54]

Hello,

I have a code that will look at the current sheet and then combine amounts found under identical headers.

While it works really well, I need to tweak it due to recently discovered issues. For instance, the employee badge might contain leading zeros and when the code runs, the zeros drop. I added in a code at the front end to update the sheet to text but when i do that, the dates obviously also follow and become serial numbers. I have tried to tweak the " Cells(1, 1 + col).Resize(rc, 1).Value = SD.items()(col)" but anything i try causes the code to clear all cells.

Basically, what i'm trying to accomplish is to:
1. Update all cells to text unless there is a "/" or is already formatted as date (whichever is easiest to code)
2. Auto size all columns so that i don't get a scientific reference. Not that i have, but more as precaution.

Thanks for looking.


Before:

Employee Badge	Employee Name	Date	Apples	Oranges	Bananas	Apples	Plums
0012	Jon Smith	01/01/2022	10	34	88	50	90
0014	Betty White	01/02/2022	6	30	76	33	57
1234	Axel Foley	01/03/2022	7	11	70	61	2
765	Nigel Tufnell	01/04/2022	6	25	25	57	81
00001	Hans Gruber	01/05/2022	6	87	68	94	79

After:

Employee Badge	Employee Name	Date	Apples	Oranges	Bananas	Plums
0012	Jon Smith	44562	60	34	88	90
0014	Betty White	44563	39	30	76	57
1234	Axel Foley	44564	68	11	70	2
765	Nigel Tufnell	44565	63	25	25	81
00001	Hans Gruber	44566	100	87	68	79

Sub Combine_Duplicate_Headers_formatting()

'Sums amounts under duplicate headers
Dim r As Range:         Set r = Range("A1").CurrentRegion
Dim rc As Integer:      rc = r.Rows.Count
Dim AR() As Variant:    AR = r.Value2
Dim SD As Object:       Set SD = CreateObject("Scripting.Dictionary")
Dim v As Variant

'changes formats to text prior to combine so that leading zeros aren't dropped if left as general format
With r
    .NumberFormat = "@"
    .Value = .Formula
End With

For i = 1 To UBound(AR, 2)
    If Not SD.exists(AR(1, i)) Then
        SD.Add AR(1, i), Application.Index(AR, 0, i)
    Else
        v = SD(AR(1, i))
        For j = 2 To UBound(v)
            v(j, 1) = v(j, 1) + AR(j, i)
        Next j
        SD(AR(1, i)) = v
    End If
Next i

r.ClearContents

For col = 0 To SD.Count - 1
    Cells(1, 1 + col).Resize(rc, 1).Value = SD.items()(col)
Next col
  For rc = 1 To ActiveSheet.UsedRange.Columns.Count
  
Next
End Sub

 

[Serafin54]

This one for example is 500 rows and 56 columns

 

[johnnyL]

Try this for now:

Sub Combine_Duplicate_Headers_formatting()

'Sums amounts under duplicate headers
Dim r As Range:         Set r = Range("A1").CurrentRegion
Dim rc As Integer:      rc = r.Rows.Count
Dim AR() As Variant:    AR = r.Value2
Dim SD As Object:       Set SD = CreateObject("Scripting.Dictionary")
Dim v As Variant
Dim cel As Range

    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    
'changes formats to text prior to combine so that leading zeros aren't dropped if left as general format

    For Each cel In r
        If Not IsDate(cel.Value) Then
            cel.NumberFormat = "@"
            cel.Value = cel.Formula
        End If
    Next


For i = 1 To UBound(AR, 2)
    If Not SD.exists(AR(1, i)) Then
        SD.Add AR(1, i), Application.Index(AR, 0, i)
    Else
        v = SD(AR(1, i))
        For j = 2 To UBound(v)
            v(j, 1) = v(j, 1) + AR(j, i)
        Next j
        SD(AR(1, i)) = v
    End If
Next i

r.ClearContents

For col = 0 To SD.Count - 1
    Cells(1, 1 + col).Resize(rc, 1).Value = SD.items()(col)
Next col
  For rc = 1 To ActiveSheet.UsedRange.Columns.Count
  
Next
    
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True

End Sub

Let us know how long that takes.

 

[Serafin54]

ok this is much faster. I just tested on a 5000 row and took about 10 seconds which considering all that is going on, is a keeper. Thank you! I did the screen updating but didn't think to do the Auto Calc toggle.

 

[johnnyL]

Glad to help.