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
Related
I am trying to hide multiple rows in an excel worksheet which are empty using following code however i am getting error message "Argument not optional". What could be wrong in the code?
Sub Attendance_Manday()
Dim sht1 As Worksheet
Dim row_count, col_count As Integer
Dim mainrange As Range
Dim startcell As Range
Set startcell = Range("B1")
Set sht1 = Sheets("Mandays")
row_count = Sheets("Mandays").Cells(Rows.Count, startcell.Column).End(xlUp).Row
col_count = Sheets("Mandays").Cells(startcell.Row, Columns.Count).End(xlToLeft).Offset(1, -2).Column
Set mainrange = sht1.Range(startcell.Address & ":" & sht1.Cells(row_count, col_count).Address)
mainrange.Range.SpecialCells(xlCellTypeBlanks).Rows.Hidden = True
End Sub
Based on your code and assuming first row in your sheet is never empty you could do something like that
Sub Attendance_Manday()
Dim sht1 As Worksheet
Dim row_count As Long, col_count As Long
Dim mainrange As Range
Dim startcell As Range
Set startcell = Range("B1")
Set sht1 = Sheets("Mandays")
row_count = Sheets("Mandays").Cells(Rows.Count, startcell.Column).End(xlUp).Row
col_count = Sheets("Mandays").Cells(startcell.Row, Columns.Count).End(xlToLeft).Offset(1, -2).Column
Set mainrange = sht1.Range(startcell.Address & ":" & sht1.Cells(row_count, col_count).Address)
Dim i As Long
For i = 1 To col_count - 1
mainrange.AutoFilter field:=i, Criteria1:="="
Next i
Dim rg As Range
Set rg = mainrange.SpecialCells(xlCellTypeVisible)
mainrange.AutoFilter
rg.Rows.EntireRow.Hidden = True
rg.Rows(1).EntireRow.Hidden = False
End Sub
An if you turn off screenupdating etc. it should be pretty fast as well
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)))
Can you help me correct my VBA codes. I want to convert the values of Column U until the active row to Absolute Values meaning to remove the negative amounts.
Here is my VBA code:
Sub MakeColumnsAbsoluteValue()
Dim sht As Worksheet
Dim rngToAbs As Range
Dim LastRow As Long
Dim c As Range
Set sht = ThisWorkbook.Sheets("MJEBlackline")
LastRow = sht.Cells(sht.Rows, Count, "U").End(xlUp).Row
Set rngToAbs = Range("U5:U" & LastRow)
For Each c In rngToAbs
c.Value = Abs(c.Value)
Next c
End Sub
Problem with line LastRow = sht.Cells(sht.Rows, Count, "U").End(xlUp).Row
Use of , instead of . and not specifying the sheet reference in rngToAbs
Try:
Sub MakeColumnsAbsoluteValue()
Dim sht As Worksheet
Dim rngToAbs As Range
Dim LastRow As Long
Dim c As Range
Set sht = ThisWorkbook.Sheets("FF")
LastRow = sht.Cells(sht.Rows.count, "U").End(xlUp).row
Set rngToAbs = sht.Range("U5:U" & LastRow)
For Each c In rngToAbs
c.Value = Abs(c.Value)
Next c
End Sub
You may try:
Sub MakeColumnsAbsoluteValue()
Dim sht As Worksheet
Dim rngToAbs As Range
Dim LastRow As Long
Set sht = ThisWorkbook.Sheets("MJEBlackline")
With sht
LastRow = .Cells(.Rows.Count, "U").End(xlUp).Row
Set rngToAbs = .Range("U5:U" & LastRow)
rngToAbs.Value = .Evaluate("=abs(" & rngToAbs.Address & ")")
End With
End Sub
Or even (inspired through #GarysStudent):
Sub MakeColumnsAbsoluteValue()
Dim sht As Worksheet
Dim rngToAbs As Range
Dim LastRow As Long
Set sht = ThisWorkbook.Sheets("MJEBlackline")
With sht
LastRow = .Cells(.Rows.Count, "U").End(xlUp).Row
Set rngToAbs = .Range("U5:U" & LastRow)
rngToAbs.Replace what:="-", lookat:=xlPart, replacement:=""
End With
End Sub
This would both convert the whole range in one go. Assuming that's what you meant with:
"I want to convert the values of Column U until the active row..."
You could try:
Option Explicit
Sub MakeColumnsAbsoluteValue()
Dim sht As Worksheet
Dim rngToAbs As Range, c As Range
Dim LastRow As Long, x As Long
Dim arr() As Variant
Set sht = ThisWorkbook.Sheets("MJEBlackline")
x = 0
With sht
LastRow = .Cells(.Rows.Count, "U").End(xlUp).Row
Set rngToAbs = .Range("U5:U" & LastRow)
'Loop range and create an array including all abs values
For Each c In rngToAbs
ReDim Preserve arr(x)
arr(x) = Abs(c.Value)
x = x + 1
Next c
'Paste the values of the array at once instead of pasting values one by one
.Range("U5:U" & LastRow).Value = Application.WorksheetFunction.Transpose(arr)
End With
End Sub
Despite reading several threads searching for answers to similar problems I have been unable to debug my code on its own.
I am trying to write a macro that will search all cells between AE and BF for the term "Aeronautics Engineers" and then copy all rows that contain that term to a new sheet. The entire sheet has a total of 99289.
I have tried using the following code without any luck:
Sub MoveAero()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
strArray = Array("Aeronautic")
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("AE" & I & ":BF" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub
Thanks for any assistance!
Your problem is in your j loop:
For J = 0 To UBound(strArray)
The UpperBound (Ubound) of array strArray is 0. It's an array with a single element "Aeronautic".
So your loop is looping once and exiting.
Instead try looping through your range:
For Each rngCell in rngCells.Cells
if rngCell.value = "Aeronatic" Then
Found = True
Exit For
End if
Next rngCell
Here we loop through that rngCells range that you just made, cell by cell. Then we test if if the cell has the value you are looking for. If we find it, we set found to true and exit the for loop. You don't have to exit the for loop, but we found what we wanted, so there is no reason not to save some cpu time.
Full code, removed unnecessary variables and moved a little bit around:
Sub MoveAero()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngCell as Range
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("AE" & I & ":BF" & I)
For Each rngCell in rngCells.Cells
if rngCell.value = "Aeronatic" Then
'Moved this logic up from the IF block below
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
Exit For
End if
Next rngCell
Next I
End Sub
Alternatively, you could use that .find method of the range object instead of the second For loop. (Using both for your needs is unnecessary).
Sub MoveAero()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim rngCells As Range
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("AE" & I & ":BF" & I)
'Try to find your search term in the range
If Not (rngCells.Find("Aeronautic") Is Nothing) Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub
I am trying to create a range based on dynamic row and column number and copy that range and paste it at another range. I am able to get row and column numbers; but not sure how to create a range out of it and use it for Copy method
Sub cut_paste()
Set TS = ThisWorkbook.Sheets("Table_Schema")
TS.Activate
Dim rng As Range`enter code here`
Dim str As String
Dim frow As Integer
Dim lRow As Integer
lRow = Cells(Rows.Count, 1).End(xlUp).Row
frow = Range("A1").End(xlDown).Row
rng1 = "A" & frow
rng2 = "H" & lRow
str = """" & rng1 & ":" & rng2 & """"
' getting error on below line
Set rng = Range(str)
TS.Range(rng).Copy
End Sub
You do not need multiple " to encapsulate your string and you do not want to create a range from a range (Range(rng)).
So, with improvements
Sub cut_paste()
Set TS = ThisWorkbook.Sheets("Table_Schema")
Dim rng As Range
Dim str As String, rng1 As String, rng2 As String
Dim frow As Integer, lRow As Integer
lRow = TS.Cells(Rows.Count, 1).End(xlUp).Row
frow = TS.Range("A1").End(xlDown).Row
rng1 = "A" & frow
rng2 = "H" & lRow
str = rng1 & ":" & rng2
TS.Range(str).Copy
End Sub
You are overdoing the string concatenation and Range object identification.
Sub cut_paste()
Dim TS As Worksheet
Dim rng As Range
Dim str As String
Dim frow As Long
Dim lRow As Long
Set TS = ThisWorkbook.Sheets("Table_Schema")
With TS
lRow = .Range("A" & Rows.Count).End(xlUp).Row
frow = .Range("A1").End(xlDown).Row
rng1 = "A" & frow
rng2 = "H" & lRow
str = rng1 & ":" & rng2
' getting error on below line
Set rng = .Range(str)
rng.Copy
'the clipboard has the copied range
End With
End Sub
I've used a With ... End With statement to reference the Table_Schema worksheet as the parent for all cell and range references.