I would like some support in correcting this simple piece of code. when running the code it is always displaying 1 and then a miss match error box pops up. I cant see why this is not working the code seems simple enough.
Sub Test3()
Dim rng As Range, cell As Range
Set rng = Range("D1:D10")
For Each cell In rng
If cell.Value > 0 Then
MsgBox Application.WorksheetFunction.CountA(cell.Value)
End If
Next cell
End Sub
Here is one way:
Sub Test3()
Dim rng As Range, cell As Range, IAmTheCount As Long
Set rng = Range("D1:D10")
IAmTheCount = 0
For Each cell In rng
If cell.Value > 0 Then
IAmTheCount = IAmTheCount + 1
End If
Next cell
MsgBox IAmTheCount
End Sub
Since you are using a for each loop, you are counting the cells one by one. That's why the Msgbox always says 1. You should not use a loop to achieve what you want
Sub Test3()
Dim rng As Range, cell As Range
Set rng = Range("D1:D10")
MsgBox Application.WorksheetFunction.CountIf(rng, ">0")
End Sub
Related
I am trying to highlight empty cells in columns K,L,M.
I tried the below code
Sub highlight()
Dim myRange As Range, cel As Range
Set myRange = Sheet1.Range("K:M")
For Each cel In myRange
If Trim(cel.Value) = "" Then cel.Interior.ColorIndex = 3
Next cel
End Sub
Looking to highlight all the empty cells.
Try:
Sub Color_blank_cells()
'declare variables
Dim ws As Worksheet
Dim ColorRng As Range
Set ws = Worksheets("WorksheetName")
Set ColorRng = ws.Range("B3:C9")
'color blank cells'
ColorRng.SpecialCells(xlCellTypeBlanks).Interior.Color = RGB(220, 230, 241)
End Sub
Your code appears to work fine, it highlights all the empty cells red. The problem is that you have no way to break out of your loop when you reach the end of your data, the code will continue to highlight empty cells all the way to the end of the sheet (to row 1,048,576) which will likely cause Excel to hang.
You could find the last row of data and break out of the loop when this row is reached. The below limits the loop to the length of column "K" (assumes all columns have the same length).
Sub highlight()
Dim myRange As Range, cel As Range
Set myRange = Sheet1.Range("K:M")
n = Sheets("Sheet1").Range("K" & Sheets("Sheet1").Rows.Count).End(xlUp).Row
For Each cel In myRange
If cel.Row > n Then Exit For
If Trim(cel.Value) = "" Then cel.Interior.ColorIndex = 3
Next cel
End Sub
I have growing data files and in a certain column is not fill out. I have the code to fill the data, though I want to make a button to call userform for user to fill in the range so that the code works within the range provided by the user(since data is adjusted by the user itself). The code to fill the blank cell is;
Sub fillblank()
Dim range As Range
Dim cell As Range
Dim value As String
Set range = Sheets("Sheet1").Range("E4:E15")
For Each cell In range
If Trim(cell.Value) <> "" Then
value = cell.Value
Else
cell.Value = value
End if
Next cell
End Sub
I would like the user to enter the range (E4:E15) in userform. How to do the userform if its dependent only range? Thanks stackoverflow.com.
Put a text box in userform and name it txtRng. Then declare a variable named MyRng as String. Assign that text box value to MyRng variable and use this variable as argument of range like...
Set range = Sheets("Sheet1").Range(MyRng)
So, full code will be like as below
Sub fillblank()
Dim range As range
Dim cell As range
Dim value As String
Dim MyRng As String
MyRng = UserForm1.txtRng 'Use your form name here
Set range = Sheets("Sheet1").range(MyRng)
For Each cell In range
If Trim(cell.value) <> "" Then
value = cell.value
Else
cell.value = value
End If
Next cell
End Sub
I also suggest you to not use range, value as variable because some of these reserve keyword. It may cause misbehave of output.
You could use the InputBox() method and have the user select a range:
Sub fillblank()
Dim myRange As Range
Dim cell As Range
Dim myValue As String
Set myRange = Application.InputBox( prompt:="Select a range", Type:=8)
For Each cell In myRange
If Trim(cell.Value) <> "" Then
myValue = cell.Value
Else
cell.Value = myValue
End if
Next
End Sub
or you could add a RefEdit control to your userform and process it
Sub fillblank()
Dim cell As range
Dim myValue As String
For Each cell In range(Me.RefEdit1.Text)
If Trim(cell.value) <> "" Then
myValue = cell.value
Else
cell.value = myValue
End If
Next cell
End Sub
In this case, since the user could input an invalid range, you may want to add a validation function (named GetRange in my following example)
Sub fillblank()
Dim myRange As range
If Not GetRange(Me.RefEdit1.Text, myRange) Then
MsgBox "Select a valid range "
Me.RefEdit1.SetFocus
Exit Sub
End If
Dim cell As range
Dim myValue As String
For Each cell In myRange
If Trim(cell.value) <> "" Then
myValue = cell.value
Else
cell.value = myValue
End If
Next cell
End Sub
Function GetRange(RefEditText As String, myRange As range) As Boolean
On Error Resume Next
Set myRange = range(RefEditText)
On Error GoTo 0
GetRange = Not myRange Is Nothing
End Function
finally, here is an alternative method (no loops) to fill blank cells as you're wanting to do:
Sub fillblank()
With range(Me.RefEdit1.Text).SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[-1]C"
.value = .value
End With
End Sub
To ask the user for a range you could use InputBox(Type:=8)
The code bellow will accept only one column
If an entire column is selected (A:A) or multiple columns it adjusts to the total rows in UsedRange and first column in selection
Option Explicit
Public Sub FillBlanks()
Dim selectedCol As Range, itm As Range, lr As Long
On Error Resume Next
Set selectedCol = Application.InputBox(Prompt:="Select column:", Type:=8)
On Error GoTo 0
If selectedCol Is Nothing Then Exit Sub 'User cancelled selection
With selectedCol
.Parent.Activate
lr = .Parent.UsedRange.Rows.Count
If .Columns.Count > 1 Then Set selectedCol = .Resize(.Rows.Count, 1)
If .Rows.Count < 2 Or .Rows.Count > lr Then Set selectedCol = .Resize(lr - .Row + 1, 1)
selectedCol.Select
End With
For Each itm In selectedCol
If Len(Trim$(itm)) = 0 And itm.Row > 1 Then itm.Value2 = itm.Offset(-1).Value2
Next
End Sub
Note: It's not recommended to name your variables with special VBA keywords
Dim range As Range - Range is the most important object in Excel
Dim value As String - Value is the most important property of the Range object
I'm trying to figure out a dynamic range that will select a range starting from the active cell in a for each loop. For instance, if cell A2 is selected in my for each cell loop, the range in the loop being A2:A20, and it contains "IP," it will select the range A2:M2, delete the contents, and shift all the values below, A3:M20, up to fill the emptied cells.
Sub deletewirelessdevice()
Dim rng As Range
Dim wksSource As Worksheet
Set wksSource = ActiveWorkbook.Sheets("dt-attext")
Set rng = wksSource.Range("A2:A500")
For Each Cell In rng
If InStr(1, ActiveSheet.Range(ActiveCell).Value, "IP") > 0 Then
Range(ActiveCell, "M" & ActiveCell.Row).Select.Delete Shift:=xlUp
Next Cell
End Sub
I'm not sure if there is a mistake in the selection and deletion as I can't get the code to run due to a Next without for compile error. There is a matching for so I don't know what the problem is. Any advice is welcome.
You had a number of issues with your code so I've tweaked it and inferred what you intended. This should work, however do read the comments above as well for some pointers on how to handle it next time
Public Sub deletewirelessdevice()
Dim DelRng As Range
Dim ColOffset As Long
With ActiveWorkbook.Sheets("dt-attext")
ColOffset = Range("M" & 1).Column - 1
For Each cell In .Range("A2:A500")
If InStr(cell.Value2, "IP") Then
If DelRng Is Nothing Then
Set DelRng = Range(cell, cell.Offset(0, ColOffset))
Else
Set DelRng = Union(DelRng, Range(cell, cell.Offset(0, ColOffset)))
End If
End If
Next cell
If Not DelRng Is Nothing Then DelRng.Delete Shift:=xlUp
End With
End Sub
In my current Excel worksheet, I would like to move the selected non-contiguous cell contents to the right and up, from this:
to this:
I tried the following macro:
Sub move()
Selection.Offset(-1, 1).Value = Selection.Value
Selection.ClearContents
End Sub
but ended up with this:
Is there a way to keep the contents of A5 and A8 after moving? Thanks!
EDIT : Finally, is it possible to delete the original rows (A2, A5, and A8 in my example) after moving the selected cell contents?
I personally do not like the use of Selection but if you insist, the following may help.
Sub test()
Dim rngTemp As Range
For Each rngTemp In Selection.Areas
rngTemp.Copy Destination:=rngTemp.Offset(-1, 1)
rngTemp.ClearContents
Next rngTemp
End Sub
Another way
Sub Sample()
Dim aCell As Range
'~~> Check if what the user selected is a valid range
If TypeName(Selection) <> "Range" Then
MsgBox "Select a range first."
Exit Sub
End If
For Each aCell In Selection
aCell.Cut Destination:=aCell.Offset(-1, 1)
Next aCell
End Sub
You may try something like this....
Sub TransformData()
Dim cell As Range
For Each cell In Selection
cell.Offset(-1, 1) = cell
Next cell
Selection.ClearContents
End Sub
No select copy data.
Sub test()
Dim rngDB As Range, rng As Range
Dim i As Long, n As Long
Set rngDB = Range("a1", Range("a" & Rows.Count).End(xlUp))
n = rngDB.SpecialCells(xlCellTypeConstants).Areas.Count
For i = 1 To n
Set rng = rngDB.SpecialCells(xlCellTypeConstants).Areas(i)
rng(rng.Rows.Count).Copy rng.Range("a1").Offset(, 1)
rng(rng.Rows.Count).Clear
Next i
End Sub
I am using the following code to clean all cells dose not containing a formula.
Sub DoNotContainClearCells()
Dim rng As Range
Dim cell As Range
Dim ContainWord As String
'What range ?
Set rng = Worksheets("Datenbasis").Range("A5:Z100")
'What I am looking for?
ContainWord = "="
For Each cell In rng.Cells
If cell.Find(ContainWord) Is Nothing Then cell.Clear
Next cell
End Sub
But I get the run time error 1004 and just the first column is removed. How can I treat this error? Is there any better way to delete cells from a sheet which dose not contain a formula?
Consider:
Sub DoNotContainClearCells()
Dim rng As Range
Set rng = Worksheets("Datenbasis").Range("A5:Z100")
rng.Cells.SpecialCells(xlCellTypeFormulas).Clear
End Sub
EDIT#1:
If you wish to clear cells not containing formulas then:
Sub DoNotContainClearCells()
Dim rng As Range
Set rng = Worksheets("Datenbasis").Range("A5:Z100")
rng.Cells.SpecialCells(xlCellTypeConstants).Clear
End Sub
will leave the formula cells alone!.
Try with below
Sub DoNotContainClearCells()
Dim rng As Range
Dim cell As Range
'What range ?
Set rng = Worksheets("Datenbasis").Range("A5:Z100")
For Each cell In rng.Cells
If Not cell.HasFormula Then cell.Clear
Next cell
End Sub