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)))
Related
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
In the code below, I have identified a range (ColRng) in which I want to check each cell - if it is empty, there is a SUMIFS function to perform. It does not work. I know my syntax and logic is horrid, but I can't figure out how to make it work.
Dim ColRng As Range
Dim LastCol As Long
Dim LastRowScenario As Long
Dim x As Long
Dim rngCrit1 As Range
Dim rngCrit2 As Range
Dim rngSum As Range
LastRowScenario = Sheets("Sheet1").Range("Q2").End(xlDown).Row
Set rngCrit1 = Sheets("Sheet1").Range("D2:D" & LastRowScenario)
Set rngCrit2 = Sheets("Sheet1").Range("B2:B" & LastRowScenario)
Set rngSum = Sheets("Sheet1").Range("Q2:Q" & LastRowScenario)
LastCol = Sheets("Summary").Range("B5").End(xlToRight).Column
Set ColRng = Range(LastCol & "6:" & LastCol & "149")
For x = ColRng.Cells.Count To 1 Step -1
With ColRng.Cells(x)
' If the cell is empty, perform a SUMIFS
If IsEmpty(.Value) Then
.Formula = Application.WorksheetFunction.SumIfs(rngSum, rngCrit1, .Range("E" & .Row).Value, rngCrit2, .Range("B" & .Row).Value)
End If
End With
Next x
Your ColRng construction is wrong - try something like this instead:
Dim ColRng As Range
Dim LastCol As Long
Dim LastRowScenario As Long
Dim x As Long
Dim rngCrit1 As Range
Dim rngCrit2 As Range
Dim rngSum As Range, ws As Worksheet, wsSumm As Worksheet
set ws = Sheets("Sheet1")
Set rngSum = ws.Range("Q2:Q" & ws.Range("Q2").End(xlDown).Row)
Set rngCrit1 = rngSum.EntireRow.Columns("D")
Set rngCrit2 = rngSum.EntireRow.Columns("B")
Set wsSumm = Sheets("Summary")
With wsSumm.Range("B5").End(xlToRight).EntireColumn
Set ColRng = wsSumm.Range(.Cells(6), .Cells(149))
End With
For x = ColRng.Cells.Count To 1 Step -1
With ColRng.Cells(x)
' If the cell is empty, perform a SUMIFS
If IsEmpty(.Value) Then
.Formula = Application.SumIfs(rngSum, _
rngCrit1, .EntireRow.columns("E").Value, _
rngCrit2, .EntireRow.columns("B").Value)
End If
End With
Next x
I would like to have up to 6 records which will be based on the answers located in the row beneath.
My code so far looks like this:
Sub Copy_Data_Correctly(ByRef datSource As Worksheet, datTarget As Worksheet)
'QUESTION 1
Const TM_PM As String = "*PM is required*"
Dim que1 As Range
Dim ans1 As Range
Set que1 = Sheets("Sheet1").Range("A1:A100").Find(What:=TM_PM, _
Lookat:=xlPart, LookIn:=xlValues)
If Not que1 Is Nothing Then
'MsgBox ("The question about PM or TM wasn't found")
End If
Set ans1 = que1.Offset(1)
'QUESTION 2
Const LID_LIFTED As String = "*be lifted*"
Dim que2 As Range
Dim ans2 As Range
Set que2 = Sheets("Sheet1").Range("A1:A100").Find(What:=LID_LIFTED, _
Lookat:=xlPart, LookIn:=xlValues)
If Not que2 Is Nothing Then
End If
Set ans2 = que2.Offset(1)
'EXTRACTING THE DATA
Dim lrow1 As Long, lrow2 As Long, lrow3 As Long, lrow4 As Long, lrow5 As Long, lrow6 As Long
lrow1 = datTarget.Range("E" & datTarget.Rows.Count).End(xlUp).Row + 1
lrow2 = datTarget.Range("F" & datTarget.Rows.Count).End(xlUp).Row + 1
que1.Copy
datTarget.Range("E1").PasteSpecial xlPasteValuesAndNumberFormats
ans1.Copy
datTarget.Range("E" & lrow1).PasteSpecial xlPasteValuesAndNumberFormats
que2.Copy
datTarget.Range("F1").PasteSpecial xlPasteValuesAndNumberFormats
ans2.Copy
datTarget.Range("F" & lrow2).PasteSpecial xlPasteValuesAndNumberFormats
End Sub
If I have the second question & answer standalone, then it works. Unfortunately after adding the Q&A1 the error:
Object variable or with variable not set
occurs at the line:
Set ans1 = que1.Offset(1)
why the code behaves like that?
Copy Conditionally
Using the Find method, it will attempt to find each string, containing wild characters, from a list in range A1:A100 of one worksheet (source), then take this matching value (which is different (no wild characters)), and by using Application.Match, it will attempt to find a match in the headers of another worksheet (destination). If a match is found, then the result, the value of the cell below the previously found cell, will be written into the first available row. If no match is found, a new header will be created from the value of the found cell, and the value below the found cell will be written into the first available row.
Option Explicit
Sub CopyData( _
ByVal wsSource As Worksheet, _
ByVal wsDestination As Worksheet)
' Add more: comma separated, no spaces
Const sCriteriaList As String = "*PM is required,*be lifted*"
Const sCriteriaListDelimiter As String = ","
Const sAddress As String = "A1:A100"
Const dfhCellAddress As String = "E1"
Dim sCriteria() As String
sCriteria = Split(sCriteriaList, sCriteriaListDelimiter)
Dim srg As Range: Set srg = wsSource.Range(sAddress)
Dim dfhCell As Range: Set dfhCell = wsDestination.Range(dfhCellAddress)
Dim dfRow As Long: dfRow = dfhCell.Row
Dim dfCol As Long: dfCol = dfhCell.Column
Dim dlhCell As Range: Set dlhCell = _
wsDestination.Cells(dfRow, wsDestination.Columns.Count).End(xlToLeft)
Dim dhrg As Range
If dlhCell.Column < dfCol Then
Set dhrg = dfhCell
Else
Set dhrg = wsDestination.Range(dfhCell, dlhCell)
End If
Dim dlCol As Long: dlCol = dhrg.Columns(dhrg.Columns.Count).Column
Dim dlCell As Range
Set dlCell = _
wsDestination.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious)
Dim dRow As Long
If Not dlCell Is Nothing Then
If dlCell.Row <= dfhCell.Row Then
dRow = dfhCell.Row + 1
Else
dRow = dlCell.Row + 1
End If
Else
dRow = dfhCell.Row + 1
End If
Dim sCell As Range
Dim sQuestion As String
Dim sAnswer As String
Dim drrg As Range
Dim dhIndex As Variant
Dim n As Long
For n = 0 To UBound(sCriteria)
Set sCell = srg.Find( _
sCriteria(n), srg.Cells(srg.Cells.Count), xlValues, xlWhole)
If Not sCell Is Nothing Then
sQuestion = sCell.Value
sAnswer = CStr(sCell.Offset(1).Value)
dhIndex = Application.Match(sQuestion, dhrg, 0)
If IsNumeric(dhIndex) Then
wsDestination.Cells(dRow, dhIndex + dfCol - 1).Value = sAnswer
Else
Set dhrg = dhrg.Resize(, dhrg.Columns.Count + 1)
dlCol = dlCol + 1
wsDestination.Cells(dfRow, dlCol).Value = sQuestion
wsDestination.Cells(dRow, dlCol).Value = sAnswer
End If
End If
Next n
End Sub
I have this function below which does the following:
Takes two parameters (Header Name, Function Needed).
The Header Name parameter is used to find the heading and subsequently to identify the range of that column up until the last row.
The Function Needed parameter is used to switch in the select statement for any additional steps needed.
At the end of most of the statements, I do a Range.Select then I exit my function with a selected range.
Here is the code:
Function find_Header(header As String, fType As String)
Dim aCell As Range, rng As Range
Dim col As Long, lRow As Long
Dim colName As String
With ActiveSheet
Set aCell = .Range("B2:J2").Find(What:=header, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
'If Found
If Not aCell Is Nothing Then
col = aCell.Column
colName = Split(.Cells(, col).Address, "$")(1)
lRow = Range(colName & .Rows.count).End(xlUp).Row + 1
Set myCol = Range(colName & "2")
Select Case fType
Case "Copy"
'This is your range
Set rng = Range(myCol.Address & ":" & colName & lRow).Offset(1, 0)
rng.Select
End Select
'If not found
Else
MsgBox "Column Not Found"
End If
End With
End Function
As I am trying to clean up my code, I have come across a section where I have specifically hard coded ranges and I am trying to make use of my function instead, however, I am now at a point where I am unable to make use of this function correctly as I cannot "pass" the range back to the sub and I cannot seem to make the selection the range object needed for the sub.
Here is what is in the sub:
Sub Copy_Failed()
Dim xRg As Range, xCell As Range
Dim i As Long, J As Long, count As Long
Dim fType As String, colName As String
Dim y As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
myarray = Array("Defect", "System", "Script")
myEnv = Array("SIT", "UAT")
myDefects = Array("New", "Existing")
i = Worksheets("Run Results").UsedRange.Rows.count
J = Worksheets("Failed").UsedRange.Rows.count
Set y = Workbooks("Template.xlsm")
Set ws1 = y.Sheets("Failed")
Set ws2 = y.Sheets("Run Results")
count = 3
If J = 1 Then
If Application.WorksheetFunction.CountA(ws1.UsedRange) = 0 Then J = 0
End If
ws2.Activate
fType = "Copy"
colName = "Status"
Call find_Header(colName, fType)
End Sub
Before I used the function, the code looked like this:
lngLastRow = Cells(Rows.count, "B").End(xlUp).Row
Set xRg = ws2.Range("E3:E" & lngLastRow & i)
Now these 2 lines are performed in the function, so I don't need it in the sub. I have tried the following:
Set rngMyRange = Selection
Set rngMyRange = ActiveSheet.Range(Selection.Address)
Set xRg = ws2.Range(rngMyRange & i)
But I get the error:
Type mismatch
So I am thinking this:
Select the range in the function then use it in the sub - but how?
Figure out how to pass the actual range object from my function to the sub
Although the second option would require some extra changes in my code, I would think this is the better option to go with.
Ok, so here is an illustration just so you can see what I mean. If you put "one" somewhere in B2:J2 it will select the range. I am only using Select here so that you can see the range it identifies. (Disclaimer: I don't fully understand what you are doing, and not sure you need all this code to achieve what you want.)
The Function now returns a range variable, and is assigned to r. Run the procedure x.
Sub x()
Dim r As Range
Set r = Range("a1", find_Header("one", "Copy"))
r.Select
End Sub
Function find_Header(header As String, fType As String) As Range
Dim aCell As Range, rng As Range
Dim col As Long, lRow As Long
Dim colName As String
With ActiveSheet
Set aCell = .Range("B2:J2").Find(What:=header, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
'If Found
If Not aCell Is Nothing Then
col = aCell.Column
colName = Split(.Cells(, col).Address, "$")(1)
lRow = Range(colName & .Rows.Count).End(xlUp).Row + 1
Set myCol = Range(colName & "2")
Select Case fType
Case "Copy"
'This is your range
Set find_Header = Range(myCol.Address & ":" & colName & lRow).Offset(1, 0)
End Select
'If not found
Else
Set find_Header = Nothing
End If
End With
End Function
I am tring to alter this code FindReplace_With_Offset_1 to FindReplace_With_Offset_2
FindReplace_With_Offset_1 Run on a Col Range and it works fine
I need FindReplace_With_Offset_2 to run only on each Cell in the Col Range i.e. I need each cell to be its own range, when I run it I get #NAME? for every Cell with value #N/A
Thanks
Sub FindReplace_With_Offset_1()
Dim wsFR As Worksheet, wsT As Worksheet
Dim tLR As Long, i As Long
Set wsT = ThisWorkbook.Worksheets("XXX")
Set wsFR = ThisWorkbook.Worksheets("ZZZ")
With wsT
tLR = .Range("C" & .Rows.Count).End(xlUp).Row
With .Range("B2:B" & tLR) 'The Offset Range
.Value = _
"=VLOOKUP(D2," & wsFR.Range("D1").CurrentRegion.Address(1, 1, , 1) & ",2,0)"
.Value = .Value
End With
End With
End Sub
Code2
Sub FindReplace_With_Offset_2()
Dim wsFR As Worksheet, wsT As Worksheet
Dim Rng As Range, aCell As Range
Dim tLR As Long, i As Long
Set wsT = ThisWorkbook.Worksheets("XXX")
Set wsFR = ThisWorkbook.Worksheets("ZZZ")
With wsT
tLR = .Range("C" & .Rows.Count).End(xlUp).Row
Set Rng = .Range("A2:A" & tLR)
For Each aCell In Rng
If aCell.text = "#N/A" Then
aCell.Value = _
"=VLOOKUP(aCell," & wsFR.Range("C1").CurrentRegion.Address(1, 1, , 1) & ",2,0)"
aCell.Value = aCell.Value
Else
aCell = aCell
End If
Next aCell
End With
End Sub
Maybe it's because you're trying to put the code to read a error value, and for the excel the cell value isn't the text "#N/A", try to use the IfError formula to run the verification on the desired cell, like this:
If WorksheetFunction.IfError(aCell,"Error") = "Error" Then