Autosum column using column header - excel

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) & ")"

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

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

Related

SUMIF Using VBA has Object Error But Unable to Resolve

I am unable to find the Object Error is appearing when i run the function. I do not why this is happening. It should work fine but no it does not. I hope to get some help and any help will be appreciated.
Sub SumIF()
Dim LastRow As Long
Dim sh As Worksheet
Set sh = Sheets("SumIF")
LastRow = sh.Cells(Rows.Count, 1).End(xlUp).Row
Table1 = sh.Range("A2:A" & LastRow) 'Need to Match this with Table3
Table2 = sh.Range("B2:B" & LastRow) 'Need to Sum this in K2:K
Table3 = sh.Range("J2:J" & LastRow)
sh.Range("K2:K" & LastRow) = Application.WorksheetFunction.SumIF(Table1, Table3, Table2)
End Sub
VBA SumIf Using .Formula
Option Explicit
Sub VBASumIfFormula()
' Workbook, Worksheet
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("SumIf")
' Source Column Ranges
Dim slRow As Long: slRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If slRow < 2 Then Exit Sub ' no data in column range
Dim slrg As Range: Set slrg = ws.Range("A2:A" & slRow) ' lookup column
Dim svrg As Range: Set svrg = slrg.Offset(0, 1) ' values column
' Destination Column Ranges
Dim dlRow As Long: dlRow = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row
If dlRow < 2 Then Exit Sub ' no data in column range
Dim dlrg As Range: Set dlrg = ws.Range("J2:J" & dlRow) ' lookup column
Dim dvrg As Range: Set dvrg = dlrg.Offset(0, 1) ' values column (empty)
' Construct formula string.
Dim FormulaString As String
FormulaString = "=IFERROR(SUMIF(" & slrg.Address & "," _
& dlrg.Cells(1).Address(0, 0) & "," & svrg.Address & "),"""")"
'Debug.Print FormulaString
' Write formulas.
dvrg.Formula = FormulaString
' Convert formulas to values.
dvrg.Value = dvrg.Value
End Sub
If you insist on doing it your way, which is less efficient since looping is necessary, you could do...
' Either...
Dim cCell As Range
For Each cCell In Table3.Cells
cCell.Offset(0, 1).Value = Application.WorksheetFunction _
.SumIf(Table1, cCell.Value, Table2)
Next cCell
' ... or:
Dim cCell As Range
For Each cCell In sh.Range("K2:K" & LastRow).Cells ' or e.g. 'Table4'
cCell.Value = Application.WorksheetFunction _
.SumIf(Table1, cCell.Offset(0, -1).Value, Table2)
Next cCell
because the second argument, criteria, is not supposed to be a range:
... criteria in the form of a number, expression, a cell reference, text, or a function...

Matching Two Strings then copy paste Data

I have been trying to make a function where it matches 2 separate strings with two column then copy corresponding columns data and paste into separate sheet.
I am stuck on that thing how to make 2 matches like For Each cell In myDataRng & myDataRng2.
your help will be appreciated
Sub Tester()
Dim myDataRng, myDataRng2 As Range
Dim cell As Range, wsSrc As Worksheet, wsDest As Worksheet
Dim destRow As Range
Dim FindValue As String
Dim FindValue2 As String
Set wsSrc = Worksheets("Sheet1") 'source sheet
Set wsDest = Worksheets("Sheet2") 'destination sheet
FindValue = wsDest.Range("A2").Value
FindValue2 = wsDest.Range("B2").Value
Set myDataRng = wsSrc.Range("F2:F" & wsSrc.Cells(Rows.Count, "F").End(xlUp).Row)
Set myDataRng2 = wsSrc.Range("A2:A" & wsSrc.Cells(Rows.Count, "A").End(xlUp).Row)
Set destRow = wsDest.Rows(2) 'first destination row
For Each cell In myDataRng
If InStr(1, cell.Value, FindValue) > 0 Then
With cell.EntireRow 'the whole matching row
destRow.Cells(5).Value = .Cells(2).Value
destRow.Cells(6).Value = .Cells(3).Value
destRow.Cells(7).Value = .Cells(4).Value
destRow.Cells(8).Value = .Cells(5).Value
End With
Set destRow = destRow.Offset(1, 0) 'next destination row
End If
Next cell
End Sub
Other Condition
Sub find()
Dim foundRng As Range
Dim mValue As String
Set shData = Worksheets("Sheet1")
Set shSummary = Worksheets("Sheet2")
mValue = shSummary.Range("C2")
Set foundRng = shData.Range("G1:Z1").find(mValue)
'If matches then copy macthed Column and paste into Sheet2 Col"I" (as above code psting the data into Sheet2)
End Sub
Several options:
If Instr(1, cell.Offset(,-5).Value, FindValue2) > 0 Then
If InStr(1, wsSrc.Range("A" & cell.Row), FindValue2) > 0 Then
and others.
I like using rows for loops like this because it makes it very easy to read the code and understand what is happening. By breaking the search range into a series of rows, everything becomes simple to write and read.
Sub Tester()
Dim myDataRng, myDataRng2 As Range
Dim rRow As Range, wsSrc As Worksheet, wsDest As Worksheet
Dim destRow As Range
Dim FindValue As String
Dim FindValue2 As String
Set wsSrc = Worksheets("Sheet1") 'source sheet
Set wsDest = Worksheets("Sheet2") 'destination sheet
FindValue = wsDest.Range("A2").Value
FindValue2 = wsDest.Range("B2").Value
Set myDataRng = wsSrc.Range("F2:F" & wsSrc.Cells(Rows.Count, "F").End(xlUp).Row)
'Set myDataRng2 = wsSrc.Range("A2:A" & wsSrc.Cells(Rows.Count, "A").End(xlUp).Row)
Set destRow = wsDest.Rows(2) 'first destination row
For Each rRow In myDataRng.Rows.EntireRow
If InStr(1, rRow.Columns("F").Value, FindValue) > 0 _
And InStr(1, rRow.Columns("A").Value, FindValue2) > 0 Then
With rRow.EntireRow 'the whole matching row
destRow.Cells(5).Value = .Cells(2).Value
destRow.Cells(6).Value = .Cells(3).Value
destRow.Cells(7).Value = .Cells(4).Value
destRow.Cells(8).Value = .Cells(5).Value
End With
Set destRow = destRow.Offset(1, 0) 'next destination row
End If
Next rRow
End Sub
Set wsSrc = Worksheets("Sheet1") 'source sheet
Set wsDest = Worksheets("Sheet2") 'destination sheet
FindValue = wsDest.Range("A2").Value
FindValue2 = wsDest.Range("B2").Value
Set myDataRng = wsSrc.Range("F2:F" & wsSrc.Cells(Rows.Count, "F").End(xlUp).Row)
'Set myDataRng2 = wsSrc.Range("A2:A" & wsSrc.Cells(Rows.Count, "A").End(xlUp).Row)
Set destRow = wsDest.Rows(2) 'first destination row
For Each rRow In myDataRng.Rows
If InStr(1, rRow.Columns("F").Value, FindValue) > 0 _
And InStr(1, rRow.Columns("A").Value, FindValue2) > 0 Then
With rRow.EntireRow 'the whole matching row
destRow.Cells(5).Value = .Cells(2).Value
destRow.Cells(6).Value = .Cells(3).Value
destRow.Cells(7).Value = .Cells(4).Value
destRow.Cells(8).Value = .Cells(5).Value
End With
Set destRow = destRow.Offset(1, 0) 'next destination row
End If
Next rRow
End Sub

Find column by name and convert it vba

How can I find in vba column by name ex. "Test1" and convert whole column to number format?
as far i manage to find the cell:
Worksheets("Sheet1").Cells.Find(What:="Test1")
Something like this:
Public Sub Test()
Dim r As Range
Set r = FindColumn("Test1")
If Not r Is Nothing Then
r.NumberFormat = "#,##0.00"
End If
End Sub
Public Function FindColumn(HeaderName As String) As Range
Dim FndCol As Range
With ThisWorkbook.Worksheets("Sheet1")
Set FndCol = .Cells.Find(HeaderName, .Cells(1, 1), xlValues, xlWhole)
If Not FndCol Is Nothing Then
Set FindColumn = FndCol.EntireColumn
End If
End With
End Function
Data Column Number Format
This solution will print the range addresses at the various stages of the code to the Immediate window (CTRL+G).
For example, in the range A1:J10 containing data, if cell C1 is equal to Test1, it will apply the number format to the range C2:C10.
Option Explicit
Sub applyColumnNumberFormat()
Const wsName As String = "Sheet1"
Const HeaderRow As Long = 1
Const Header As String = "Test1"
Const nFormat As String = "#.00"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim hrg As Range: Set hrg = ws.Rows(HeaderRow) ' Header Row Range
Debug.Print "Header Row Range: " & hrg.Address(0, 0)
Dim hCell As Range ' Header Cell Range
Set hCell = hrg.Find(Header, hrg.Cells(hrg.Cells.Count), _
xlFormulas, xlWhole)
If Not hCell Is Nothing Then
Debug.Print "Header Cell Address: " & hCell.Address(0, 0)
Dim lCell As Range ' Last Non-Empty Cell Range
Set lCell = ws.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious)
Debug.Print "Last Non-Empty Cell: " & lCell.Address(0, 0)
Dim drg As Range ' Destination Range - Occupied Cells Below the Header
Set drg = hCell.Resize(lCell.Row - hCell.Row).Offset(1)
Debug.Print "Destination Range: " & drg.Address(0, 0)
drg.NumberFormat = nFormat
Else
Debug.Print "Header '" & Header & "' not found."
End If
End Sub
The following code assumes your column headings are on row 1.
The Find function returns a range object. You can use the Column property of the range to identify the column you want to format.
Dim r As Range
Dim col As Integer
Set r = Worksheets("Sheet1").Rows(1).Find(What:="Test")
If r Is Nothing Then
'Column heading not found
Else
col = r.Column
Worksheets("Sheet1").Columns(col).NumberFormat = "0.00"
End If

Sum a range for a specific column

I want to build a dynamic reporting, and for that, if the header is equal to a specific text then sum the entire column below the header. This is the code that I have.
Sub FindIfSumColumn()
Dim LastRow As Long
Dim rgFound As Range
Dim mFound As Range
Dim bd As Worksheet: Set bd = Sheets("BDD")
Dim dt As Worksheet: Set dt = Sheets("DICT")
LastCol = bd.Cells(1, Columns.Count).End(xlToLeft).Column
Set mFound = dt.Range("B2")
Set rgFound = bd.Range("A1:XFD" & LastCol).Find(What:=mFound, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
If rgFound Is Nothing Then
MsgBox "Nothing"
Else
LastRow = rgFound.Cells(Rows.Count, 1).End(xlUp).Row
dt.Range("B4") = Application.WorksheetFunction.Sum(LastRow)
End If
End Sub
Logic:
Find the header
Get the row below the header
Get the last row under that header
Create your range to sum
Find sum
TIP: It will be easier if you give meaningful names to your variables. That way it will be easier to understand what they are for
Is this what you are trying?
Option Explicit
Sub FindIfSumColumn()
Dim StartRow As Long, LastRow As Long
Dim FoundColumn As String
Dim StringToFind As String
Dim ResultRange As Range
Dim sumRng As Range
Dim bd As Worksheet: Set bd = Sheets("BDD")
Dim dt As Worksheet: Set dt = Sheets("DICT")
StringToFind = dt.Range("B2").Value
Set ResultRange = bd.Cells.Find(What:=StringToFind, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns)
If ResultRange Is Nothing Then
MsgBox "Nothing"
Else
'~~> Get the row after the header
StartRow = ResultRange.Row + 1
'~~> Column of the header
FoundColumn = Split(Cells(, ResultRange.Column).Address, "$")(1)
'~~> Last row under that header
LastRow = bd.Range(FoundColumn & bd.Rows.Count).End(xlUp).Row
'~~> The range that we need to sum
Set sumRng = bd.Range(FoundColumn & StartRow & ":" & FoundColumn & LastRow)
'~~> Output
dt.Range("B4") = Application.WorksheetFunction.Sum(sumRng)
End If
End Sub
Replace, please, your code row
dt.Range("B4") = Application.WorksheetFunction.Sum(LastRow)
with
dt.Range("B4") = Application.WorksheetFunction.Sum(bd.Range(rgFound.Offset(1, 0), rgFound.Offset(lastRow, 0)))

Find word in column and copy lines below on different sheet

I have source data which are not aligned to table.
I want to find text (e.g. Account), copy the two whole lines below the cell with the found text (Account) and paste them on a different Sheet. Then search down and do again until the data ends. Data should be pasted in the order it is reached.
The cell with word "Account" will be always in the column A. The search should be for the exact word "Account", because in the column can be cells which contain e.g. "Payer account".
This code shows me an error msg
"Run-time error 438 - object doesnt support this property or method"
Private Sub Search_n_Copy()
Dim LastRow As Long
Dim rng As Range, C As Range
With Worksheets("INPUT_2") ' <-- here should be the Sheet's name
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
Set rng = .Range("A1:A" & LastRow) ' set the dynamic range to be searched
' loop through all cells in column A and copy below's cell to sheet "Output_2"
For Each C In rng
If C.Value = "Account" Then
C.Offset(-1, 0).Copy C.Offset.OUTPUT_2(-7, -1) ' use offset to put value in sheet "Output_2", column E
End If
Next C
End With
End Sub
This post doesn't point out what the error in your original code is. Ron Rosenfeld has already covered that in the comment.
Here is another faster way (as compared to looping) which uses .Find/.FindNext to achieve what you want. It also doesn't copy the rows in a loop but copies in the end.
Private Sub Search_n_Copy()
Dim ws As Worksheet
Dim rngCopy As Range, aCell As Range, bcell As Range
Dim strSearch As String
strSearch = "Account"
Set ws = Worksheets("INPUT_2")
With ws
Set aCell = .Columns(1).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bcell = aCell
If rngCopy Is Nothing Then
Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2))
Else
Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2)))
End If
Do
Set aCell = .Columns(1).FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bcell.Address Then Exit Do
If rngCopy Is Nothing Then
Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2))
Else
Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2)))
End If
Else
Exit Do
End If
Loop
Else
MsgBox SearchString & " not Found"
End If
'~~> I am pasting to Output sheet. Change as applicable
If Not rngCopy Is Nothing Then rngCopy.Copy Sheets("Output").Rows(1)
End With
End Sub
Screenshot
The codle would be like this. This code Use variant.
Private Sub Search_n_Copy()
Dim LastRow As Long
Dim rng As Range, C As Range
Dim vR(), n As Long, k As Integer, j As Integer
Dim Ws As Worksheet
With Worksheets("INPUT_2") ' <-- here should be the Sheet's name
.Columns("e").ClearContents
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
Set rng = .Range("A1:A" & LastRow) ' set the dynamic range to be searched
' loop through all cells in column A and copy below's cell to sheet "Output_2"
For Each C In rng
If C.Value = "Account" Then
For j = 1 To 2
n = n + 1
ReDim Preserve vR(1 To 6, 1 To n)
For k = 1 To 6
vR(k, n) = C.Offset(j, k - 1) ' use offset to put value in sheet "Output_2", column E
Next k
End If
Next C
If n > 0 Then
Set Ws = Sheets.Add '<~~~ Sheets("your sheet name")
With Ws
.Range("a1").Resize(n, 6) = WorksheetFunction.Transpose(vR)
End With
End If
End With
End Sub

Resources