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
Related
I'm trying to round every populate cell in column AD:AD to 4 decimals and ends when the next cell is blank.
I thought something like this would work but it errors out on the cell.value.
Sub Round_4()
For Each cell In [AD:AD]
If cell = "" Then Exit Sub
cell.Value = WorksheetFunction.Round(cell.Value, 4)
Next cell
End Sub
Any suggestions?
You could work only down to the first empty cell with
Range("AD1", Range("AD1").End(xlDown)).Value = Evaluate("round(" & Range("AD1", Range("AD1").End(xlDown)).Address & ",4)")
Note this is using Activesheet reference. You can wrap in a With statement giving the parent sheet.
You could do this:
Dim myCell As Range
Dim myRange As Range
Set myRange = Excel.Application.ThisWorkbook.Worksheets(worksheetNameGoesHereInDoubleQuotes).Range("AD:AD")
For Each myCell In myRange
If Not IsEmpty(myCell) Then
myCell.Value = Application.WorksheetFunction.Round(CDbl(myCell.Value), 4)
'me being lazy with my range assignment
ElseIf IsEmpty(myCell) Then
Exit For
End If
Next
I am writing an excel macro that will grab information that is highlighted in one excel workbook and paste it into a new workbook.
The code I currently have takes the info from specific cells, but I need it to be of certain cells that are highlighted throughout the spreadsheet.
The code I currently have is
Sub copy()
Workbooks("Book2.xlsx").Worksheets("Master Data").Range("A8:I14").copy _
Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1")
End Sub
EDIT
By highlighted, I do not mean highlighted with a colour or with formatting. I mean by selecting a multitude of cells by click and dragging to select cells
Option Explicit
Sub CopySpecificRange()
Dim srcRange As Range
Set srcRange = Worksheets(1).Range("A8:I14")
Dim myCell As Range
Dim srcRangeColored As Range
For Each myCell In srcRange
If myCell.Interior.Color = vbYellow Then
If Not srcRangeColored Is Nothing Then
Set srcRangeColored = Union(srcRangeColored, myCell)
Else
Set srcRangeColored = myCell
End If
End If
Next myCell
If Not srcRangeColored Is Nothing Then
srcRangeColored.copy Worksheets(2).Range("A2")
End If
End Sub
Concerning that you want only cells, colored in vbYellow the code above works. Just make sure that you fix correctly the Worksheets(2) and Worksheets(1) as you wish.
Depending on what you want, probably it is a better idea to save the colored values in a data structure (array or list), and to put it one after another in range A2. Thus, consider that you are interested in the yellow cells of A1:D10 range only:
Thus, trying to get this:
You may use the myColl as a Collection and add any vbYellow cell to it. Then, using the incremented cnt, it is easy to put the values of the collection on a single row:
Sub CopySpecificRange()
Dim srcRange As Range
Set srcRange = Worksheets(1).Range("A1:D10")
Dim myCell As Range
Dim srcRangeColored As Range
Dim myColl As New Collection
For Each myCell In srcRange
If myCell.Interior.Color = vbYellow Then
myColl.Add myCell.Value2
End If
Next myCell
Dim cnt As Long: cnt = 1
With Worksheets(2)
For Each myCell In .Range(.Cells(1, 1), .Cells(1, myColl.Count))
myCell = myColl.Item(cnt)
cnt = cnt + 1
Next myCell
End With
End Sub
And concerning the edit, where highlighted means selected.
Input:
Output:
Sub CopySelectedRanges()
Dim myCell As Range
Dim srcRangeColored As Range
Dim myColl As New Collection
For Each myCell In Selection.Cells
myColl.Add myCell.Value2
Next myCell
Dim cnt As Long: cnt = 1
With Worksheets(2)
For Each myCell In .Range(.Cells(1, 1), .Cells(1, myColl.Count))
myCell = myColl.Item(cnt)
cnt = cnt + 1
Next myCell
End With
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
I have a list called "District List" on one tab and a Template that is driven by putting the name of a district into Cell C3. Each District has a wildly varying number of branches (between 1 & 500+ branches depending on the District) so the report template has a lot of blank space in some cases. I came up with this to loop through the District List, copy the Template tab, rename it the District Name, insert the name of the district into Cell C3, and then I have another loop to hide the blank rows.
It works, but it takes forever, like 5 minutes per tab, then after about four tabs, I get an object error at the first like of Sub CreateTabsFromList.
Is there a problem with the code, or is this just a really inefficient way to do this? If so can anyone help with a better method?
Sub HideRows()
Dim r As Range, c As Range
Set r = Range("a1:a1000") 'Sets range well beyond the last possible row with data
Application.ScreenUpdating = False
For Each c In r
If Len(c.Text) = 0 Then
c.EntireRow.Hidden = True 'Hide the row if the cell in A is blank
Else
c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
Sub CreateSheetsFromAList()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("District List").Range("A1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets("Template").Copy After:=Sheets(Sheets.Count) 'creates a new worksheet
Range("C3").Value = MyCell.Value 'Pastes value in C3
Sheets(Sheets.Count).Name = MyCell.Value 'renames worksheet
HideRows 'Hides rows where cell in column A is ""
Next MyCell
End Sub
Deleting/Hiding rows, 1 by 1 is the slowest method. Always club them in one range and delete/hide them in one go, also looping through cells is slower than looping array.
Sub HideRows()
Dim lCtr As Long
Dim rngDel As Range
Dim r As Range
Dim arr
Set r = Range("a1:a1000") 'Sets range well beyond the last possible row with data
Application.ScreenUpdating = False
arr = r
For lCtr = LBound(arr) To UBound(arr)
If arr(lCtr, 1) = "" Then
If rngDel Is Nothing Then
Set rngDel = Cells(lCtr, 1) 'harcoded 1 as you are using column A
Else
Set rngDel = Union(rngDel, Cells(lCtr, 1))
End If
End If
Next
If Not rngDel Is Nothing Then
rngDel.EntireRow.Hidden=True
End If
Application.ScreenUpdating = True
End Sub
takes fraction of a second for 1000 rows.
I am trying to do something simple. From column N in Log Frame info copy only unique values starting at B62 of Dropdown - this part works! Then, if one of the values in B62:B80 is "other" delete that cell - this part works sometimes and not others, can't tell why. Help!
Sub test()
Dim RngDest As Range
Dim Rng As Range, Cell As Range
Sheets("Dropdowns").Range("b61:b80").ClearContents
Set Rng = Sheets("Log Frame Info").Range("N4:N500")
Set RngDest = Sheets("Dropdowns").Range("B62")
Rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=RngDest, Unique:=True
With Sheets("Dropdowns")
Set Rng = Range("B61:b80")
For Each Cell In Rng
If Cell = "Other" Then
Cell.Delete
End If
Next Cell
End With
End Sub
The reason is because once a cell has been deleted, the For loop is continuing to the next cell rather than evaluating the new value of the cell. Something like this should work as it counts when a cell has been deleted and offsets the If call:
Sub test()
Dim RngDest As Range
Dim Rng As Range, Cell As Range
Dim i As Integer
Sheets("Dropdowns").Range("b61:b80").ClearContents
Set Rng = Sheets("Log Frame Info").Range("N4:N500")
Set RngDest = Sheets("Dropdowns").Range("B62")
Rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=RngDest, Unique:=True
With Sheets("Dropdowns")
Set Rng = Range("B61:b80")
For Each Cell In Rng
If Cell.Offset(-i, 0) = "Other" Then
Cell.Delete
i = i + 1
End If
Next Cell
End With
End Sub