How to autosum column using column header in vba code? I am trying to autosum few columns in excel sheet but column position is changing every time.

Dim Rng             As Range
Dim c               As Range

Set Rng = Range("F1:F" & Range("F1").End(xlDown).Row)

Set c = Range("F1").End(xlDown).Offset(1, 0)

c.Formula = "=SUM(" & Rng.Address(False, False) & ")"

Set Rng = Range("G1:G" & Range("G1").End(xlDown).Row)

Set c = Range("G1").End(xlDown).Offset(1, 0)

c.Formula = "=SUM(" & Rng.Address(False, False) & ")"

Set Rng = Range("H1:H" & Range("H1").End(xlDown).Row)

Set c = Range("H1").End(xlDown).Offset(1, 0)

c.Formula = "=SUM(" & Rng.Address(False, False) & ")"

CodePudding user response：

Find Headers to Insert Autosum (Application.Match)

• It is assumed that the headers are in the first row of the worksheet's used range.

Sub InsertAutosum()

    Dim Headers(): Headers = Array("Sales 2020", "Sales 2021", "Sales 2022")
    
    Dim ws As Worksheet: Set ws = ActiveSheet
    
    Dim trg As Range ' Table Range
    
    With ws.UsedRange
        Dim lCell As Range
        Set lCell = .Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If lCell Is Nothing Then Exit Sub
        Set trg = .Resize(lCell.Row - .Row   1)
    End With
    
    Dim hrg As Range: Set hrg = trg.Rows(1) ' Header Range
    
    Dim trCount As Long: trCount = trg.Rows.Count
    Dim srg As Range: Set srg = trg.Resize(trCount - 1).Offset(1) ' Sum Range
    
    Dim Header, cIndex, sFormula As String
    
    For Each Header In Headers
        cIndex = Application.Match(Header, hrg, 0)
        If IsNumeric(cIndex) Then
            sFormula = "=SUM(" & srg.Columns(cIndex).Address(, 0) & ")"
            hrg.Offset(trCount).Cells(cIndex).Formula = sFormula
        End If
    Next Header

End Sub

CodePudding user response：

how to autosum column using column header in vba code

If you know the column header, then it becomes very easy. Here is an example. Let's say the header of the column is SOME-HEADER and we are not sure which column it is in but the headers are in row 1. If they are not in row 1 then you will have to tweak the code accordingly.

I have commented the code but if you still have a question then simply ask.

Option Explicit

Sub Sample()
    Dim Ws As Worksheet
    
    Dim HeaderText As String
    Dim HeaderRow As Long
    Dim HeaderColumn As Long
    
    Dim LastRow As Long
    Dim LastColumn As Long
    
    Dim rng As Range
    
    Dim i As Long
    
    '~~> Change this to the relevant worksheet
    Set Ws = Sheet1
    
    '~~> Column Header text. Change as applicable
    HeaderText = "SOME-HEADER"
    
    '~~> Headers are in row 1. Change as applicable
    HeaderRow = 1
    
    With Ws
        '~~> Check if there is data in the worksheet
        If Application.WorksheetFunction.CountA(.Cells) = 0 Then
            MsgBox "There is no data in thw worksheet"
            Exit Sub
        End If
        
        '~~> Find last column
        LastColumn = .Cells(HeaderRow, .Columns.Count).End(xlToLeft).Column

        '~~> We can use .Find to find the header row but it may be an overkill
        '~~> So we use a simple loop
        For i = 1 To LastColumn
            '~~> Checking for an exact match.
            If UCase(Trim(.Cells(HeaderRow, i).Value)) = UCase(Trim(HeaderText)) Then
                HeaderColumn = i
                Exit For
            End If
        Next i
        
        '~~> Check if we found the column
        If HeaderColumn = 0 Then
            MsgBox "Unable to find the column"
            Exit Sub
        End If
        
        '~~> Find the last row in the column
        LastRow = .Cells(.Rows.Count, HeaderColumn).End(xlUp).Row
        
        '~~> This is the range
        Set rng = .Range(.Cells(2, HeaderColumn), .Cells(LastRow, HeaderColumn))
        
        '~~> Insert Sum Formula
        .Cells(LastRow   1, HeaderColumn).Formula = "=Sum(" & _
                                                    rng.Address(False, False) & _
                                                    ")"
    End With
End Sub

SCREENSHOT