I basically want a macro to insert the selection as comments to a selected range. So basically I would require to have two selected ranges? How does this work?
My problem- I have the comments for the cells in a different sheet in rows. And in the second sheet I have column headers for which I need those rows as comments to be inserted.
Sub TextIntoComments_GetFromRight()
Dim cell As Range
Selection.ClearComments
For Each cell In Intersect(Selection, ActiveSheet.UsedRange)
If Trim(cell.Offset(0, 1).Text) <> "" Then
cell.AddComment cell.Offset(0, 1).Text
cell.Comment.Visible = False
cell.Comment.Shape.TextFrame.AutoSize = True
End If
Next cell
End Sub
The following code will accept two range inputs from the user. One for the range that needs comments, and one for the range of comments. These two ranges must be the same size. It will then add the text from the second range as comments to the first range. This will work regardless of which sheet the two ranges are on.
Sub TextIntoComments_GetFromRight()
Dim CommentRange As Range
Dim CellComments As Range
Dim cell As Range
Dim cell2 As Range
Dim ws1 As Worksheet, ws2 As Worksheet
Set CommentRange = Range("A1")
Set CellComments = Range("A1:A2")
Do Until CommentRange.Rows.Count = CellComments.Rows.Count And CommentRange.Columns.Count = CellComments.Columns.Count
Set CommentRange = Application.InputBox("Select the range that needs comments.", Type:=8)
Set CellComments = Application.InputBox("Select the range of comments to be inserted.", Type:=8)
If CommentRange.Rows.Count <> CellComments.Rows.Count Or CommentRange.Columns.Count <> CellComments.Columns.Count Then MsgBox "The range sizes do not match. Please select matching range sizes.", vbCritical
Loop
Set ws1 = CommentRange.Worksheet
Set ws2 = CellComments.Worksheet
CommentRange.ClearComments
For Each cell In CommentRange
Set cell2 = ws2.Cells(CellComments.Row + (cell.Row - CommentRange.Row), CellComments.Column + (cell.Column - CommentRange.Column))
If cell2.Text <> "" Then
cell.AddComment cell2.Text
cell.Comment.Visible = False
cell.Comment.Shape.TextFrame.AutoSize = True
End If
Next cell
End Sub
Related
the aim of my problem is to find a specific value (Text) and then refer to the entire row (or even better only the used range to the right of my active cell) in a For/Each loop.
The first part works fine of finding my value, however, the code for targeting the row of the active cell (so the cell found by the find function), does not work yet:
Sub Search()
Dim cell As Range
Dim Count As Long
Set cell = Cells.Find(what:="Planned Supply at BP|SL (EA)", LookIn:=xlValues, lookat:=xlWhole)
For Each cell In ActiveCell.EntireRow
If cell.Value = "0" Then
Count = Count + 1
End If
Next cell
Range("I1").Value = Count
End Sub
The following code will find the range to the right of your found cell and use your loop to do the comparision for each cell in the range. That part could probably be improved by using WorksheetFunction.CountIf.
Option Explicit
Sub Search()
Dim wks As Worksheet
Set wks = ActiveSheet
Dim cell As Range, sngCell As Range
Dim Count As Long
Set cell = wks.Cells.Find(what:="Planned Supply at BP|SL (EA)", LookIn:=xlValues, lookat:=xlWhole)
If cell Is Nothing Then Exit Sub ' just stop in case no hit
Dim rg As Range, lastColumn As Long
With wks
lastColumn = .Cells(cell.Row, .Columns.Count).End(xlToLeft).Column ' last used column in cell.row
Set rg = Range(cell, .Cells(cell.Row, lastColumn)) ' used rg right from found cell inlcuding found cell
End With
' loop from the original post
For Each sngCell In rg
If sngCell.Value = "0" Then
Count = Count + 1
End If
Next
Range("I1").Value = Count
End Sub
I have a list of names on one sheet (InputSheet) in the range c6:H200. The names in this range change twice a month. The group of names in the InputSheet are compared to a list of names on another sheet (NameList) in the range e2:e50. For each name that is found on the NameList, I want to remove the name on the InputSheet. I'm new to vba but have written this code and it is not working (getting run time error). Thanks for any help!
Sub RemoveNonWords()
Dim datasheet As Worksheet
Dim cl As Range
Set wordrange = InputSheet.Range("C6:h200")
Set datasheet = NameList.Range("E1:E50").Value
For Each cl In wordrange
If cl = datasheet Then
cl.Selection.ClearContents
End If
Next
Range("A6").Select
End Sub
There's a lot wrong with your posted code. I think in the end, this is what you're looking for, code commented for clarity:
Sub tgr()
Dim wb As Workbook
Dim wsInput As Worksheet
Dim wsNames As Worksheet
Dim rInputData As Range
Dim rNameList As Range
Dim DataCell As Range
Dim rClear As Range
Dim lRow As Long
Set wb = ActiveWorkbook
Set wsInput = wb.Sheets("InputSheet") 'Change to the actual sheet name of your input sheet
Set wsNames = wb.Sheets("NameList") 'Change to the actual sheet name of your name list sheet
'Get last used row of the C:H columns in wsInput
With wsInput.Range("C:H")
lRow = .Find("*", .Cells(1), , , , xlPrevious).Row
If lRow < 6 Then Exit Sub 'No data
End With
'Use the last used row to define your inputdata range, this was hardcoded to C6:H200 in your question
Set rInputData = wsInput.Range("C6:H" & lRow)
'Define the namelist range using all populated cells in column E of wsNames, this was hardcoded to E2:E50 in your question
Set rNameList = wsNames.Range("E2", wsNames.Cells(wsNames.Rows.Count, "E").End(xlUp))
If rNameList.Row < 2 Then Exit Sub 'No data
'Data has been found and ranges assigned
'Now loop through every cell in rInputData
For Each DataCell In rInputData.Cells
'Check if the cell being looked at exists in the NameList range
If WorksheetFunction.CountIf(rNameList, DataCell.Value) > 0 Then
'Found to exist, add the cell to the Clear Range
If rClear Is Nothing Then
Set rClear = DataCell 'First matching cell added
Else
Set rClear = Union(rClear, DataCell) 'All subsequent matching cells added
End If
End If
Next DataCell
'Test if there were any matches and if so clear their contents
If Not rClear Is Nothing Then rClear.ClearContents
End Sub
I have the following code which loops through two different worksheets and compares column A to column A checking if the same value is on the other sheet. If it is then the row is colored in green.
Dim compareRange As Range
Dim toCompare As Range
Dim rFound As Range
Dim cel As Range
Set compareRange = Worksheets("sheet2").Range("A1:A" & Lastrow3)
Set toCompare = Worksheets("sheet3").Range("A1:A" & Lastrow4)
Set rFound = Nothing
For Each cel In toCompare
Set rFound = compareRange.Find(cel)
If Not rFound Is Nothing Then
cel.EntireRow.Interior.Color = 5296274
Set rFound = Nothing
End If
Next cel
Now that I have the cell with the row how do I grab the cells from the same row but on different column? because now I want to check if column L from sheet2 matches column L from sheet3. If it doesn't I want to be grab that value from sheet2 and put it in a new row below on in the same column L. Any guidance or help would be appreciated.
This should help demostrate how to do what youre after
Private Sub compAre()
Application.ScreenUpdating = False
Dim sht1 As Range
Dim rcell As Range
Set sht1 = ThisWorkbook.Sheets("Sheet1").Range("A1:A3")
For Each rcell In sht1.Cells
If rcell.Value = ThisWorkbook.Sheets("Sheet2").Range("L" & rcell.Row).Value Then
sht1.Rows.Interior.Color = vbBlue
End If
Next rcell
Application.ScreenUpdating = True
End Sub
Here's some code that covers most of what you describe, coloring the cells that match and putting those into column L of the 3rd sheet. I didn't understand the remainder of the question after that, but this should give you a good start. The animation starts by showing the contents of sheets 1,2,3 and then shows those sheets again after running the macro.
Option Explicit
Sub test()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, num As Integer
Dim r1 As Range, r2 As Range, r3 As Range, cell1 As Range, cell2 As Range
Set sh1 = Worksheets("1")
Set sh2 = Worksheets("2")
Set sh3 = Worksheets("3")
Set r1 = Range(sh1.Range("A1"), sh1.Range("A1").End(xlDown))
Set r2 = Range(sh2.Range("A1"), sh2.Range("A1").End(xlDown))
Set r3 = sh3.Range("L1")
For Each cell1 In r1
For Each cell2 In r2
If cell1 = cell2 Then
cell1.Interior.Color = vbGreen
cell2.Interior.Color = vbGreen
r3 = cell1.Value
Set r3 = r3.Offset(1, 0)
num = num + 1
End If
Next
Next
MsgBox (num & " were found to match")
End Sub
I have range of cells on Sheet2 F2:F41, which I want to paste into visible cells in Sheet1. Visible cells on Sheet1 are in Range M111:M643. My Problem is, Excel pastes it to another cells as I want.
Snippet for it:
Do I miss loop or something like this?
Sheets("Tabelle2").Select
Dim tgt As Worksheet
Set tgt = ThisWorkbook.Sheets("Tabelle1")
Dim from As Range
Dim destination As Range
Set from = Sheets("Tabelle2").Range("F2:F41") Selection.Copy
Set destination = Sheets("Tabelle1").Range("M11:M643").SpecialCells(xlCellTypeVisible) from.Copy Destination:=Sheets("Tabelle1").Range("M111")
I found this on the internet - I forget where (could have been stackoverflow) - but it should do what you are looking for. You may want to edit out the plethora of messages, I find them helpful to ensure I'm copying pasting the ranges I intended.
Public Sub Copy_Paste_Visible_Cells()
'This subroutine only handles copying visible cells in a SINGLE COLUMN
Dim RangeCopy As Range
Dim RangeDest As Range
Dim rng1 As Range
Dim dstRow As Long
Set RangeCopy = Application.InputBox("Select a range to copy ", "Obtain Range Object", Type:=8)
MsgBox "The range you selected to copy is " & RangeCopy.Address
Set RangeDest = Application.InputBox("Select range to paste onto ", "Obtain Range Object", Type:=8)
MsgBox "The range you have selected to paste onto is " & RangeDest.Address
If RangeCopy.Cells.Count > 1 Then
If RangeDest.Cells.Count > 1 Then
If RangeCopy.SpecialCells(xlCellTypeVisible).Count <> RangeDest.SpecialCells(xlCellTypeVisible).Count Then
MsgBox "Data could not be copied"
Exit Sub
End If
End If
End If
If RangeCopy.Cells.Count = 1 Then
'Copying a single cell to one or more destination cells
For Each rng1 In RangeDest
If rng1.EntireRow.RowHeight > 0 Then
RangeCopy.Copy rng1
End If
Next
Else
'Copying a range of cells to a destination range
dstRow = 1
For Each rng1 In RangeCopy.SpecialCells(xlCellTypeVisible)
Do While RangeDest(dstRow).EntireRow.RowHeight = 0
dstRow = dstRow + 1
Loop
rng1.Copy RangeDest(dstRow)
dstRow = dstRow + 1
Next
End If
Application.CutCopyMode = False
End Sub
Please try this code.
Sub copythis(ByRef rFrom As Range, ByRef rTo As Range)
Dim rVisible As Range
Set rVisible = rFrom.SpecialCells(xlCellTypeVisible)
rVisible.Copy destination:=rTo
End Sub
that should be called like:
Sub caller()
copythis "range with hidden to be copied", "range to receive"
End Sub
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