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...
Related
wish you all the best.
I am making a code using VBA to find and detect errors from one sheet and paste the values from column A and B from the row of the error to the destination sheet.
my code is mostly working my issue is the content that is pasting which is the error cell and the next one to the right instead of the values from A and B (example: imagine macro is running all values in column K and there is an error in K85, it is pasting K85 and L85, instead of A85 and B85)
Sub Copy_NA_Values()
Dim rng As Range
Dim firstBlank As Range
Dim shtSource As Worksheet
Dim shtDestination As Worksheet
Set shtSource = ThisWorkbook.Sheets("JE Royalty detail") 'Change to the name of the source sheet
Set shtDestination = ThisWorkbook.Sheets("DB") 'Change to the name of the destination sheet
Set rng = shtSource.Range("F:F").SpecialCells(xlCellTypeFormulas, xlErrors)
For Each cell In rng
If IsError(Range("F:F")) = False Then
Set firstBlank = shtDestination.Range("K" & Rows.Count).End(xlUp).Offset(1, 0)
cell.Resize(1, 2).Copy firstBlank
End If
Next cell
End Sub
How can I make it so it will paste the correct cells i have tried to use paste special but I might've used it wrongly but I had errors, all help apreciated.
Have a good one.
it is pasting K85 and L85, instead of A85 and B85
Try replacing:
cell.Resize(1, 2).Copy firstBlank
with
shtSource.Range("A" & cell.Row & ":B" & cell.Row).Copy firstBlank
To paste only values, do this instead:
shtSource.Range("A" & cell.Row & ":B" & cell.Row).Copy
firstBlank.PasteSpecial (xlPasteValues)
Copy Values When Matching Error Values
Option Explicit
Sub BackupErrorValues()
Const SRC_NAME As String = "JE Royalty detail"
Const SRC_ERROR_RANGE As String = "F:F"
Const SRC_COPY_RANGE As String = "A:B"
Const DST_NAME As String = "DB"
Const DST_FIRST_CELL As String = "A2"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range
On Error Resume Next ' to prevent error if no error values
Set srg = Intersect(sws.UsedRange, sws.Columns(SRC_ERROR_RANGE)) _
.SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If srg Is Nothing Then
MsgBox "No cells with error values found.", vbExclamation
Exit Sub
End If
Set srg = Intersect(srg.EntireRow, sws.Range(SRC_COPY_RANGE))
Dim cCount As Long: cCount = srg.Columns.Count
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
If dws.FilterMode Then dws.ShowAllData ' prevent failure of 'Find' method
Dim dCell As Range
With dws.UsedRange
Set dCell = .Find("*", , xlFormulas, , xlByRows, xlPrevious)
End With
If dCell Is Nothing Then
Set dCell = dws.Range(DST_FIRST_CELL)
Else
Set dCell = dws.Cells(dCell.Row + 1, dws.Range(DST_FIRST_CELL).Column)
End If
Dim drrg As Range: Set drrg = dCell.Resize(, cCount)
Dim sarg As Range, srCount As Long
For Each sarg In srg.Areas
srCount = sarg.Rows.Count
drrg.Resize(srCount).Value = sarg.Value
Set drrg = drrg.Offset(srCount)
Next sarg
MsgBox "Error rows backed up.", vbInformation
End Sub
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
I'm trying to make a SUMIF using VBA to sum the values until the end of the column, always changing the criteria of the sum using the previus cell of the previous column as parameter.
Sub SOMA()
Dim r As Range
For Each r In Range("E1")
r = ("E1" + 1)
LastRow = Range("E" & Rows.Count).End(xlUp).Row
Range("F1:F" & LastRow) = WorksheetFunction.SumIfs(Range("A:A"), Range("B:B"), Range(r))
Next r
End Sub
the r should always change to E1,E2,E3,etc. until end of the column. Because the E is always a new criteria.
Edit 1:
Sorry for my bad explaning, what i expected was make a SUMIF(A:A;E1;B:B) row by row placing the values on column F always changing the criteria to E2,E3,E4,etc. until the end of the column F.
VBA SumIfs
Option Explicit
Sub SOMA()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
Dim slRow As Long: slRow = sws.Range("B" & sws.Rows.Count).End(xlUp).Row
Dim scrg As Range: Set scrg = sws.Range("B2:B" & slRow) ' Criteria Range
Dim ssrg As Range: Set ssrg = sws.Range("A2:A" & slRow) ' Sum Range
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet1")
Dim dlRow As Long: dlRow = dws.Range("E" & dws.Rows.Count).End(xlUp).Row
Dim dcrg As Range: Set dcrg = dws.Range("E2:E" & dlRow) ' Criteria Range
Dim dsrg As Range: Set dsrg = dws.Range("F2:F" & dlRow) ' Sum Range
Dim dcOffset As Long: dcOffset = dsrg.Column - dcrg.Column
Application.ScreenUpdating = False
Dim dcCell As Range ' Criteria Cell
' Loop.
For Each dcCell In dcrg.Cells
dcCell.Offset(, dcOffset).Value = Application.SumIfs(ssrg, scrg, dcCell)
Next dcCell
Application.ScreenUpdating = True
MsgBox "Soma is done.", vbInformation
End Sub
I think you want multiple SUMIFS in column F where column E has the criteria. If so you don't need a loop, you can just enter the formula in F1 and use FILLDOWN to complete the rest
Sub SOMA()
Dim LastRow as Long
LastRow = Range("E" & Rows.Count).End(xlUp).Row
Range("F1") = WorksheetFunction.SumIfs(Range("A:A"), Range("B:B"), Range("E1"))
Range("F1:F"&LastRow).FillDown
End Sub
From what’s in your code I’m assuming:
column E is being SUMIF’d
column A is the range being assessed for the SUMIF
column B is providing the criteria for the SUMIF
the SUMIF value is being output to column F
This is how I’d do it…
Sub Soma()
Dim wf As WorksheetFunction
Dim r_A As Range, r_B As Range, r_E As Range, r_F As Range
Set wf = Application.WorksheetFunction
For i = 0 To ActiveSheet.Range("E1048576").End(xlUp).Row - 1
Set r_A = Range(Range("A1"), Range("A1").Offset(i, 0))
Set r_B = Range("B1").Offset(i, 0)
Set r_E = Range(Range("E1"), Range("E1").Offset(i, 0))
Set r_F = Range("F1").Offset(i, 0)
r_F = wf.SumIf(r_A, r_B, r_E)
Next
End Sub
I am trying to copy data from multiple sheets and paste it into Sheet1. The result paste it into Sheet1 but the same row each time and not the next row of previous copied data. Here is my code. Any help is really appreciate. Thank you!
Sub LoopCopySheetsData()
Dim i As Integer
Dim wb As Workbook
Dim totalWS As Long
Set wb = ActiveWorkbook
'totalWS = wb.Sheets.Count
totalWS = 4
For i = 2 To totalWS 'Start of the VBA loop
If i < totalWS + 1 Then
Sheets(i).Select
With wb.Sheets(i)
Set findHeadRow = .Range("A:A").Find(What:="Data", LookIn:=xlValues)
End With
headRow = findHeadRow.Row
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Sheets(i).Range("A" & headRow + 1 & ":A" & lastRow).Copy
Range("A1").Activate
With wb.Sheets("Sheet1")
lastRowMaster = Cells(Rows.Count, "D").End(xlUp).Row
Sheets("Sheet1").Range("D" & lastRowMaster + 1).PasteSpecial xlPasteValues
End With
End If
Next i
End Sub
Copy Columns From Multiple Worksheets
If the header cell (Data) contains a formula, you will have to use xlValues instead of xlFormulas (first occurrence).
Adjust the values in the constants section.
Option Explicit
Sub LoopCopySheetsData()
' Source
Const sCol As String = "A"
Const sHeader As String = "Data"
' Destination
Const dName As String = "Sheet1"
Const dCol As String = "D"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range
Set dfCell = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Offset(1)
Dim sws As Worksheet
Dim srg As Range ' Range
Dim shCell As Range ' Header Cell
Dim slCell As Range ' Last Cell
Dim rCount As Long ' Source/Destination Rows Count
For Each sws In wb.Worksheets
If StrComp(sws.Name, dName, vbTextCompare) <> 0 Then ' exclude 'dws'
' Find header cell and last cell.
With sws.Columns(sCol)
Set shCell = _
.Find(sHeader, .Cells(.Cells.Count), xlFormulas, xlWhole)
Set slCell = .Find("*", , xlFormulas, , , xlPrevious)
End With
If Not shCell Is Nothing Then
If Not slCell Is Nothing Then
rCount = slCell.Row - shCell.Row ' without header
If rCount > 0 Then
Set srg = shCell.Offset(1).Resize(rCount)
dfCell.Resize(rCount).Value = srg.Value ' copy
Set dfCell = dfCell.Offset(rCount) ' next
End If
End If
End If
End If
Next sws
MsgBox "Done.", vbInformation
End Sub
Please heed this post: How to avoid using Select in Excel VBA. As second answer mentions, avoid any use of ActiveWorkbook, Activate, and Select for efficiency, maintenance, and readability.
Instead, explicitly qualify all Workbook, Worksheet, Cells, Range, and other objects. In fact, consider range assignment and avoid the need of copy and paste:
Sub LoopCopySheetsData()
Dim i As Integer, totalWS As Integer
Dim headRow As Long, lastRow As Long, headRowMaster As Long, lastRowMaster As Long
'totalWS = ThisWorkbook.Sheets.Count
totalWS = 4
For i = 2 To totalWS
If i < (totalWS + 1) Then
With ThisWorkbook.Sheets(i)
headRow = .Range("A:A").Find(What:="Data", LookIn:=xlValues).Row
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With ThisWorkbook.Sheets("Sheet1")
headRowMaster = .Cells(.Rows.Count, "D").End(xlUp).Row
lastRowMaster = headRowMaster + (lastRow - headRow)
' ASSIGN VALUES BY RANGE
.Range("D" & headRowMaster + 1 & ":D" & lastRowMaster).Value = _
ThisWorkbook.Sheets(i).Range("A" & headRow + 1 & ":A" & lastRow).Value
End With
End If
Next i
End Sub
I'm trying to do a macro to produce a list based on a lookup list. For some reason the outer loop doesnt work, it only iterates once.
Sub Macro5()
Dim LookupRng As Range
Dim Store As String
Dim jrow As Integer
Dim irow As Integer
Dim i As Integer
Dim j As Integer
Set LookupRng = Sheet1.Range("B2") ' The Lookup range
jrow = Sheet2.Range("T" & Rows.Count).End(xlUp).Row ' last row of list of values to be searched
irow = Sheet1.Range("B" & Rows.Count).End(xlUp).Row ' last row of lookup range
Sheet3.Range("A2:A" & Rows.Count).Clear
For j = 2 To jrow
Store = Sheet2.Cells(j, 20).Value ' the value to be searched in the lookup range
For i = 1 To irow
If LookupRng.Value = Store Then
Sheet3.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = LookupRng.Offset(0, -1).Value
End If
Set LookupRng = LookupRng.Offset(1, 0)
Next i
Next j
The i loop works, it searches all values that match "Store", but for some reason the j loop doesnt seem to be working, it doesnt jump to the next value of the "Store" list.
I'm new to this so would prefer a simple solution, but any help will be very appreciated
Loops with Offset
The issue was that you are not resetting the Lookup Range to the initial position after each inner loop finishes. So the following loops were trying to compare the values below the Lookup Range which were empty.
You should abandon the idea of 'offsetting' and use Cells or Range and increase the rows or define the range and use a For Each loop. But the best would be to use only one loop and use Application.Match to find a match.
A Quick Fix
Option Explicit
Sub lookupLoop()
Dim ilCell As Range ' Initial Lookup Cell Range
Dim lCell As Range ' Lookup Cell Range
Dim dCell As Range ' Destination Cell Range
Dim Store As Variant ' Current Value in Search Range
Dim iRow As Long ' Last Row of Lookup Range
Dim jRow As Long ' Last Row of Search Range
Dim i As Long ' Lookup Range Rows Counter
Dim j As Long ' Search Range Rows Counter
Set ilCell = Sheet1.Range("B2")
iRow = Sheet1.Range("B" & Sheet1.Rows.Count).End(xlUp).Row
jRow = Sheet2.Range("T" & Sheet2.Rows.Count).End(xlUp).Row
Sheet3.Range("A2:A" & Sheet3.Rows.Count).Clear
Set dCell = Sheet3.Range("A2")
For j = 2 To jRow
Store = Sheet2.Cells(j, "T").Value
Set lCell = ilCell '***
For i = 2 To iRow
If lCell.Value = Store Then
dCell.Value = lCell.Offset(0, -1).Value
Set dCell = dCell.Offset(1)
Exit For
End If
Set lCell = lCell.Offset(1)
Next i
Next j
End Sub
An Application.Match solution might look like this:
Sub lookupAM()
Dim lrg As Range ' Lookup Range (Read)
Dim vrg As Range ' Values Range (Write)
Dim srg As Range ' Search Range
Dim sCell As Range ' Current Cell in Search Range
Dim dCell As Range ' Current Cell in Destination Range
Dim cMatch As Variant ' Current Match
Dim lRow As Long ' Last Row of Lookup Range
Dim sRow As Long ' Last Row of Search Range
lRow = Sheet1.Range("B" & Sheet1.Rows.Count).End(xlUp).Row
Set lrg = Sheet1.Range("B2:B" & lRow)
Set vrg = lrg.Offset(, -1)
sRow = Sheet2.Range("T" & Sheet2.Rows.Count).End(xlUp).Row
Set srg = Sheet2.Range("T2:T" & sRow)
Sheet3.Range("A2:A" & Sheet3.Rows.Count).Clear
Set dCell = Sheet3.Range("A2")
For Each sCell In srg.Cells
cMatch = Application.Match(sCell.Value, lrg, 0)
If IsNumeric(cMatch) Then
dCell.Value = vrg.Cells(cMatch).Value
End If
Set dCell = dCell.Offset(1)
Next sCell
End Sub