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
Related
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
I'm trying to loop through all worksheets (except the first two), copying a value from each one, and then placing the copied value into a column. This is what I have so far. It isn't giving me an error message, but it's also not working.
Sub copyGrades()
Dim ws As Excel.Worksheet
Dim grade As Double
Dim rng As Range
Dim rcell As Range
Set rng = ThisWorkbook.Worksheets("Student List").Range("H2:H174")
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Rubric" And ws.Name <> "Student List" Then
grade = ws.Range("E11").Value
For Each rcell In rng.Cells
rcell.Value = grade
Next rcell
End If
Next ws
End Sub
I couldn't get the nested loops to work, but I was able to solve it using another method (looking for a match between the worksheet name and the values in a given column).
Sub copyGrades()
Dim ws As Excel.Worksheet
Dim rng As Range
Dim rcell As Range
Set rng = ThisWorkbook.Worksheets("Student List").Range("F2:F174")
For Each rcell In rng.Cells
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = rcell.Value Then
rcell.Offset(0, 3).Value = ws.Range("E11").Value
End If
Next ws
Next rcell
End Sub
I think this is how I would do it (surely not the only way):
Option Explicit
Sub copyGrades()
Dim ws As Excel.Worksheet
Dim grade As Double
Dim rng As Range
Dim count As Integer
count = 1
Set rng = ThisWorkbook.Worksheets("Student List").Range("H2:H174")
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Rubric" And ws.Name <> "Student List" Then
grade = ws.Range("E11").Value
rng.Cells(count, 1) = grade
count = count + 1
End If
Next
End Sub
Looking for a simple loop through the range (say column A range("A5:A15")) if there is a blank cell within that range I need the entire row/rows associated with the blank cell/cells to be hidden.
I was thinking of something like this to accommodate various ranges but get "type Mismatch" error. Any reasons why
Sub test()
Dim rng As Range, cell As Variant, ar As Variant
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range
Dim MyArray(1 To 4) As Range
With ThisWorkbook.Worksheets("sheet1")
'Set MyArray = rng
Set MyArray(1) = Range("O8:O17")
Set MyArray(2) = Range("O55:O64")
Set MyArray(3) = Range("G37:G46")
Set MyArray(4) = Range("G89:G98")
'ar = Array(Rng1, Rng2, Rng3, Rng4)
'Set rng = .Range("O8:O17")
For Each cell In MyArray
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next cell
End With
End Sub
?
Something Like this:
You can put it in a subject:
For Each cell In Range("A5:A15")
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next
For Each cell In Range("A40:A55")
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next
New Answer :
Dim rng As Range, cell As Variant, ar As Variant
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range
Dim MyArray(1 To 4) As Range
With ThisWorkbook.Worksheets("sheet1")
'Set MyArray = rng
Set MyArray(1) = Range("O8:O17")
Set MyArray(2) = Range("O55:O64")
Set MyArray(3) = Range("G37:G46")
Set MyArray(4) = Range("G89:G98")
'ar = Array(Rng1, Rng2, Rng3, Rng4)
'Set rng = .Range("O8:O17")
Dim i As Integer
For i = LBound(MyArray) To UBound(MyArray)
For Each cell In MyArray(i)
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next
Next
End With
Try:
Option Explicit
Sub test()
Dim rng As Range, cell As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .Range("A5:A15")
For Each cell In rng
If cell.Value = "" Then
.Rows(cell.Row).EntireRow.Hidden = True
End If
Next cell
End With
End Sub
This takes full advantage of the Excel VBA model. I'm guessing it's faster than the above but have not conducted performance tests.
Dim Cell As Range
For Each Cell In Range("A5:A15").SpecialCells(xlCellTypeBlanks)
Cell.EntireRow.Hidden = True
Next
Try the following
Option Explicit
Sub youcouldhaveatleasttriedtodosomethingyourself()
Dim r1 As Range, r2 As Range, c As Range, target As Range
With Workbooks(REF).Sheets(REF)
Set r1 = .Range("A1:A54")
Set r2 = .Range("F3:F32")
Set target = Application.Union(r1, r2)
For Each area In target.Areas
For Each c In area
If c.Value = vbNullString Then .Rows(c.Row).EntireRow.Hidden = True
Next c
Next area
End With
End Sub
Please note that I now have set two exemplifying ranges. You can always add more range variables to the Union function.
I want to compare all cells of sheet 1 to sheet 2 and matched values turn yellow, following code i used,
Sub match()
Dim varSheetA As Variant
Dim varSheetB As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
strRangeToCheck = "A1:IV65536"
varSheetA = Worksheets("Sheet1").Range(strRangeToCheck)
varSheetB = Worksheets("Sheet2").Range(strRangeToCheck)
Debug.Print Now
For icell = LBound(varSheetA, 1) To UBound(varSheetA, 1)
If varSheetA(icell) = varSheetB(icell) Then
cell.Interior.Color = vbYellow
`enter code here` End If
Next icell
End Sub
Try
Sub match()
Dim shtA As Worksheet
Dim shtB As Worksheet
Dim strRangeToCheck As String
Dim cA as range, cB as range
strRangeToCheck = "A1:IV65536"
set shtA = Worksheets("Sheet1")
set shtB = Worksheets("Sheet2")
Debug.Print Now
For Each cA IN shtA.Range(strRangeToCheck)
on error resume next
if cA.value <> "" then
Set cB = shtB.Range(strRangeToCheck).find(what:=cA.value, lookin:=xlvalues, lookat:=xlwhole)
If Not cB is Nothing then
cA.Interior.Color = vbYellow
End If
end if
on error goto 0
Next cA
End Sub
I am trying to insert a new row into a named range. The user selects a "category" from a combo box e.g., Cool Drinks, Beer and Cider, Bitters etc... and then the contents of that category populate another combo box.
I have named the ranges of all of the Categories and would like them to populate the second combo box. I have a code which works by itself:
Dim rng As Range
Dim DailySales As Worksheet
Set DailySales = Worksheets("Daily Sales")
Set rng = DailySales.Range("CoolDrinksDailySales")
For Each rng In DailySales.Range("CoolDrinksDailySales")
Me.CmboName.AddItem rng.Value
Next rng
However, whenever I try to use that in a Select Case, it doesn't work.
Dim rng As Range
Dim DailySales As Worksheet
Set DailySales = Worksheets("Daily Sales")
Select Case Me.CmboType.Value
Case "Cool Drinks"
Set rng = DailySales.Range("CoolDrinksDailySales")
For Each rng In DailySales.Range("CoolDrinksDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Beer and Cider"
Set rng = DailySales.Range("BeerCiderDailySales")
For Each rng In DailySales.Range("BeerCiderDailySales")
Me.CmboName.AddItem rng.Value
Next rng
End Select
Does anybody have any ideas?
Here is the complete code:
Option Explicit
Private Sub UserForm_Initialize()
'InitializeTypeCombo
Dim Types() As String
Types = Split("Cool Drinks,Beer and
Cider,Bitters,Brandy,Whiskey,Rum,Spirits,Sherry,White Wine,Red Wine",
",")
Dim i As Integer
For i = LBound(Types) To UBound(Types)
Me.CmboType.AddItem Types(i)
Next
'InitializeNameCombo
Dim rng As Range
Dim DailySales As Worksheet
Set DailySales = Worksheets("Daily Sales")
Select Case Me.CmboType.Value
Case "Cool Drinks"
Set rng = DailySales.Range("CoolDrinksDailySales")
For Each rng In DailySales.Range("CoolDrinksDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Beer and Cider"
Set rng = DailySales.Range("BeerCiderDailySales")
For Each rng In DailySales.Range("BeerCiderDailySales")
Me.CmboName.AddItem rng.Value
Next rng
End Select
End Sub
Private Sub CmdExit_Click()
Unload Me
End Sub
Private Sub CmdEnter_Click()
Dim rng As Range
'Store Date Index
Dim colArray(32) As Integer
'Store Item Index
Dim rowArray(150) As Integer
'Store first value for Find and FindNext
Dim FirstAddress As String
Dim i As Integer
Dim j As Integer
i = 0
j = 0
With Range("B6:AD6")
Set rng = .Find(TxtDate.Value, LookIn:=xlValues)
If Not rng Is Nothing Then
FirstAddress = rng.Address
Do
Set rng = .FindNext(rng)
colArray(i) = rng.Column
i = i + 1
Loop While Not rng Is Nothing And rng.Address <> FirstAddress
End If
End With
With Range("A7:A150")
Set rng = .Find(CmboName.Value, LookIn:=xlValues)
If Not rng Is Nothing Then
FirstAddress = rng.Address
Do
Set rng = .FindNext(rng)
rowArray(j) = rng.Row
j = j + 1
Loop While Not rng Is Nothing And rng.Address <> FirstAddress
End If
End With
Dim c As Integer
Dim r As Integer
For c = 0 To i - 1
For r = 0 To j - 1
Cells(rowArray(r), colArray(c)).Value = TxtNoSold.Value
Next r
Next c
Unload Me
End Sub
The solution was simply moving the Select Case into the Combobox_Change event. As Dick Kusleika said, the value of the combobox was nothing at runtime. Here is the correct code to accomplish what I was trying to do.
Option Explicit
Private Sub Userform_Initialize()
'Populate cmboTypes
Dim Types() As String
Types = Split("Cool Drinks,Beer and _
Cider,Bitters,Brandy,Whiskey,Rum,Spirits,Sherry,White Wine,_
Red Wine", ",")
'Loop through the values populated in the split function above, and add
'each item to the combobox
Dim i As Integer
For i = LBound(Types) To UBound(Types)
Me.CmboType.AddItem Types(i)
Next
End Sub
Sub CmboType_Change()
Dim rng As Range
Dim DailySales As Worksheet
'Populate CmboName with named dynamic ranges of "Types"
Set DailySales = Worksheets("Daily Sales")
Select Case Me.CmboType.Value
Case "Cool Drinks"
Set rng = DailySales.Range("CoolDrinksDailySales")
For Each rng In DailySales.Range("CoolDrinksDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Beer and Cider"
CmboName.Clear
Set rng = DailySales.Range("BeerCiderDailySales")
For Each rng In DailySales.Range("BeerCiderDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Bitters"
CmboName.Clear
Set rng = DailySales.Range("BittersDailySales")
For Each rng In DailySales.Range("BittersDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Brandy"
CmboName.Clear
Set rng = DailySales.Range("BrandyDailySales")
For Each rng In DailySales.Range("BrandyDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Whiskey"
CmboName.Clear
Set rng = DailySales.Range("WhiskeyDailySales")
For Each rng In DailySales.Range("WhiskeyDailySales")
Me.CmboName.AddItem rng.Value
Next rng
End Select
End Sub