Macro for highlighted cells rather than specific cells - vba

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

Related

Highlighting empty cells within columns

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

Excel-VBA: Inputting range in userform call

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

Dynamic Range with For Each Loop

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

Check merged cell and compare adjacent to set unique value from compared cells values

I'm writing a macro in Excel 2010 for a problem that is as follows:
I have two columns, one with a Key string value and one with a uuid. The idea is that every key should have only one uuid but as the table is now, key cell could be merged cells or single cells.
The macro needs to recognize which cells are merged and which are not, so, I have two options:
If cell is merged, check all its adjacent cells, pick first uuid value and copy/paste it to other adjacent cells, that is to say, cell below(Could be with an Offset())
If cell is not merged , but key value is repeated in multiple cells, copy/paste uuid value to adjacent cells.
So basically is to check merged cells MergeArea but I don't know if I need to iterate through its addresses or check cells in the range with an offset of Offset(0,1) or what.
With my code I can know if the cells are merged but now, how con I iterate through it's adjacent cells values?
Code as is now:
Sub CopyUUID()
Dim lRow As Long
Dim rng As Range
Dim ws As Worksheet
Dim rMerged As Range
Dim value As Variant
Set ws = Sheets(ActiveSheet.Name)
On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
Application.DisplayAlerts = False 'We can cancel the procedure without errors
With ws
lRow = .Range("F" & .Rows.count).End(xlUp).row
Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
rng.Select
For Each cell In rng
If cell.MergeCells Then
'Code for merged cells
Else
'Code to use for single cells
End If
Next cell
End With
ExitProgram:
Exit Sub
End Sub
Option Explicit
Sub CopyUUID()
Const UUID As Long = 31 'col AE
Dim lRow As Long, cel As Range, isM As Boolean, copyID As Boolean, kCol As Long
With ActiveSheet
kCol = -25 'col F
lRow = .Cells(.Rows.Count, UUID + kCol).End(xlUp).Row
For Each cel In .Range(.Cells(3, UUID), .Cells(lRow, UUID))
isM = cel.Offset(0, kCol).MergeCells
copyID = isM And Len(cel.Offset(0, kCol)) = 0
copyID = copyID Or (Not isM And cel.Offset(0, kCol) = cel.Offset(-1, kCol))
If copyID Then cel = cel.Offset(-1)
Next
End With
End Sub
Try the following code. Note that this is going to overwrite the current contents of UUID, so make a backup copy before testing. If you don't want the UUID column modified, you can modify this to suit your needs.
Sub CopyUUID()
Dim lRow As Long
Dim rng As Range
Dim c As Range
Dim ws As Worksheet
Dim rMerged As Range
Dim value As Variant
Set ws = Sheets(ActiveSheet.Name)
On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
' Application.DisplayAlerts = False 'We can cancel the procedure without errors
With ws
lRow = .Range("F" & .Rows.Count).End(xlUp).Row
Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
' rng.Select
For Each c In rng
If c.MergeCells Then
'Code for merged cells
c.Offset(0, 1).Formula = c.MergeArea.Cells(1, 1).Offset(0, 1).Formula
Else
'Code to use for single cells
If c.Formula = c.Offset(-1, 0).Formula Then
c.Offset(0, 1).Formula = c.Offset(-1, 1).Formula
End If
End If
Next c
End With
ExitProgram:
Exit Sub
End Sub
When in a MergedCell, it makes the UUID the same as the UUID of the first cell in the merged area. When not in a MergedCell, it copies UUID from the row above if Key is the same as the row above.
I changed your variable cell to c (I don't like to use variable names that can be confused with built-ins) and commented out a couple of lines.
Hope this helps
I adopt a simple approach to this problem as illustrated through steps taken by me.
sample sheet showing data with merged cells and unmerged cells.
Run the program code to unmerge the cells. Output of the program is appended below.
If this structure of data matches your case then addition of 2 lines of code for column B will leave the data as per following image.
Program code is as follows:
'Without column deletion:
Sub UnMergeRanges()
Dim cl As Range
Dim rMerged As Range
Dim v As Variant
For Each cl In ActiveSheet.UsedRange
If cl.MergeCells Then
Set rMerged = cl.MergeArea
v = rMerged.Cells(1, 1)
rMerged.MergeCells = False
rMerged = v
End If
Next
End Sub
'With coumn deletion
Sub UnMergeRangesB()
Dim cl As Range
Dim rMerged As Range
Dim v As Variant
For Each cl In ActiveSheet.UsedRange
If cl.MergeCells Then
Set rMerged = cl.MergeArea
v = rMerged.Cells(1, 1)
rMerged.MergeCells = False
rMerged = v
End If
Next
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
End Sub

Delete cells with a specific value

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