In VBA, I wish to find the row count of a filtered column, so I wrote VBA code as
FilteredRowCount = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Rows.Count
But FilteredRowCount always return value of 1, what would cause this?
Do like this
Sub test()
Dim Ws As Worksheet
Dim rngDB As Range
Dim r As Integer
Dim rng As Range
Set Ws = ActiveSheet
Set rngDB = Ws.UsedRange.SpecialCells(xlCellTypeVisible)
For Each rng In rngDB.Areas
r = r + rng.Rows.Count
Next rng
MsgBox r
End Sub
Related
I currently have the following VBA Code:
Sub SearchProjects()
Dim Ws As Worksheet
Dim NewSheet As Worksheet
Set NewSheet = Worksheets("Sheet1")
Dim Rng As Range, rng2 As Range
Dim myCell As Object
Dim cell2 As Object
Dim proj As String, d As Date
Dim m As Variant
Set Ws = Worksheets("Project tasks")
Ws.Activate
Set Rng = Ws.Range("D:D")
Set rng2 = Range("DatesByWeek").EntireRow 'row 4 of my "Sheet1"
searchString = "Lisa"
For Each Cell In Rng
If InStr(Cell, searchString) > 0 Then
proj = Cells(Cell.Row, Range("ProjectName").Column)
'so here d is a date found that corresponds to Lisa's project name, e.g. d = "25/07/2022"
d = Format(Cells(Cell.Row, Range("StartDate").Column), "dd/mm/yyyy")
m = WorksheetFunction.Match(d, rng2, 1) 'Searches Row 4 for any matches to the date d
msgbox(m)
End If
Next Cell
End Sub
When I do in normal excel function =MATCH("25/07/2022", 4:4, 1) it does return the correct column number, however the vba code continues to get the error:
Unable to get the match property of the WorksheetFunction class.
I'm not sure why it is an error in VBA?
Any help appreciated
Maybe you could try: (Just from the top of my head, have not been able to replicate the error)
Dim res As Variant
res = WorksheetFunction.Match(d, rng2, 1)
If Not IsError(res) Then
Msgbox res
End If
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'm currently working on a Macro that its currently filtering a table based on a value and then it copies the data under a column after the filters have been applied (got that to work). However, I can't figure out how to paste those values in the same table overwriting the data under the visible cells within a different column. Values highlighted in red (picture) are being copied, now I need to paste them over only in the cells highlighted yellow. Thank you!
Public Sub DxcDateUpdate()
Application.ScreenUpdating = False
Dim Mwb As Workbook
Dim ws As Worksheet
Set Mwb = ThisWorkbook
Set ws = Mwb.Worksheets("Commission")
Set ws2 = Mwb.Worksheets("test")
lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
ws.Range("A1").AutoFilter Field:=31, Criteria1:="DXC/TPV.com Enrollment"
ws.Range("AG2:AG" & lr).SpecialCells(xlCellTypeVisible).Copy Destination:=ws.Range '''here is where idk what to do?'''
Application.ScreenUpdating = True
End Sub
You cannot paste a discontinuous range as discontinuous. You should iterate between each range cell and copy it using offset, or building the range to Paste using c.row. Please, try the next adapted code:
Sub DxcDateUpdate()
Dim Mwb As Workbook, ws As Worksheet, rngVis As Range, c As Range, LR As Long
Set Mwb = ThisWorkbook
Set ws = Mwb.Worksheets("Commission")
Set ws2 = Mwb.Worksheets("test")
LR = ws.cells(ws.rows.Count, 1).End(xlUp).row
ws.Range("A1").AutoFilter field:=31, Criteria1:="DXC/TPV.com Enrollment"
Set rngVis = ws.Range("AG2:AG" & LR).SpecialCells(xlCellTypeVisible)
For Each c In rngVis.cells
c.Offset(0, -28).value = c.value
Next
End Sub
In order to make the code faster, of course, you should use some optimization lines (ScreenUpdating = False, EnableEvents = False, Calculation = xlCalculationManual, followed after by True, True, xlCalculationAutomatic).
Copy 'Filtered' Values Using Arrays
The following will loop through the criteria column to find the criteria (string). When found, in the same row, the value from the source column will be copied to the destination column.
The columns' values are written to arrays to speed up the process (the loop).
Option Explicit
Sub DxcDateUpdate()
Const wsName As String = "Commission"
Const fRow As Long = 2
Const cCol As String = "AE" ' Criteria
Const sCol As String = "AG" ' Source
Const dCol As String = "E" ' Destination
Const Criteria As String = "DXC/TPV.com Enrollment"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
Dim lRow As Long: lRow = rg.Rows.Count
Dim cData As Variant: cData = rg.Columns(cCol).Value
Dim sData As Variant: sData = rg.Columns(sCol).Value
With rg.Columns(dCol)
Dim dData As Variant: dData = .Value
Dim r As Long
For r = fRow To lRow
If cData(r, 1) = Criteria Then
dData(r, 1) = sData(r, 1)
End If
Next r
.Value = dData
End With
End Sub
I want to find the last non-empty cell in a given range. My solution does not work...
Public Sub Table_And_Layout()
Dim wsRoadmap As Worksheet
Dim rGoalL As Range
Set wsRoadmap = Sheets("Roadmap")
Set rGoalL = wsRoadmap.Range("A12:A20").End(xlUp)
MsgBox rGoalL.Address
End Sub
If you want to find the cell most on the right in the rows covered by your range, try this:
Public Sub Table_And_Layout()
Dim wsRoadmap As Worksheet
Dim rTarget As Range
Dim rGoalL As Range
Dim dColumn As Double
Set wsRoadmap = Sheets("Roadmap")
For Each rTarget In wsRoadmap.Range("A12:A20")
If dColumn < wsRoadmap.Cells(rTarget.Row, wsRoadmap.Columns.Count).End(xlToLeft).Column Then
Set rGoalL = wsRoadmap.Cells(rTarget.Row, wsRoadmap.Columns.Count).End(xlToLeft)
dColumn = rGoalL.Column
End If
Next
MsgBox rGoalL.Address
End Sub
Looping through the cells of the range, from the lowest row up and checking (For Each myCell In myRange(i).Cells) should be ok:
Function GetLastNonEmptyRow(myRange As Range) As Long
Dim i As Long
Dim firstCell As Long: firstCell = myRange.Cells(1, 1)
Dim myCell As Range
For i = firstCell + myRange.Rows.Count To firstCell Step -1
For Each myCell In myRange(i).Cells
If myCell <> "" Then
GetLastNonEmptyRow = myCell.Row
Exit Function
End If
Next myCell
Next i
GetLastNonEmptyRow = -1 'means that the whole range is non-empty
End Function
Called this way:
Sub TestMe()
Dim myRange As Range: Set myRange = Worksheets(1).Range("F8:G11")
Debug.Print GetLastNonEmptyRow(myRange)
End Sub
I have the below code which transfers all visible data from "Prepsheet" to "Contract".
The code refers to each visible section in Prepsheet, resizes the area in contract and then transfers the data.
I want to refer to specific columns within the filtered area, so that I can transfer column specific data individually. For example, I may only want to transfer the 1st and 6th columns. Please can someone assist
Public rnga As Range
Sub test()
Dim wb As Excel.Workbook
Set wb = ActiveWorkbook
Dim sourceWS As Excel.Worksheet
Set sourceWS = Prepsheet
Dim filteredDataRange As Excel.Range
Set filteredDataRange = sourceWS.AutoFilter.Range.Offset(1, 0)
Set filteredDataRange = filteredDataRange.Resize(filteredDataRange.Rows.CountLarge - 1)
Set filteredDataRange = filteredDataRange.SpecialCells(xlCellTypeVisible)
Dim destinationWS As Excel.Worksheet
Dim destinationRow As Long
destinationRow = 1
Dim area As Excel.Range
For Each area In filteredDataRange.Areas
Set rnga = area
MatchSelectionArea
Next area
End Sub
Sub MatchSelectionArea()
Dim rng As Range, cel As Range
Dim nRows As Long
Dim nCols As Long
Set cel = Contract.Range("a1048576").End(xlUp).Offset(1, 0)
nRows = rnga.Rows.Count
nCols = rnga.Columns.Count
Set rng = cel.Resize(nRows, nCols)
rng.Value = rnga.Value
End Sub
You are delving too deeply into the filtered rows and using the number of filtered rows to redefine the filtered range. You can copy straight out of a filtered range and you will only paste the visible rows.
Sub test()
Dim wb As Excel.Workbook, fdRng As Range, v As Long, vCOLs As Variant
Dim sourceWS As Worksheet, destinationWS As Worksheet
Set wb = ActiveWorkbook
Set sourceWS = wb.Worksheets("Prepsheet")
vCOLs = Array(1, 3, 5) 'columns A, C and E
With sourceWS
If .AutoFilterMode Then
With .AutoFilter.Range
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
For v = LBound(vCOLs) To UBound(vCOLs)
.Columns(vCOLs(v)).Copy _
destination:='YOU HAVE PROVIDED NO DEFINED DESTINATION
Next v
End With
End With
End If
End With
End Sub
Sub MatchSelectionArea()
Dim rng As Range, cel As Range
Dim nRows As Long, nCols As Long
With Worksheets("Contract")
Set cel = .Range("a1048576").End(xlUp).Offset(1, 0)
nRows = rnga.Rows.Count
nCols = rnga.Columns.Count
'cannot determine what this actually does
Set rng = cel.Resize(nRows, nCols)
rng = rnga.Value
End With
End Sub