I am trying to reset the formatting of my excel sheet, the problem is that I have 4 columns which should be date format. How can I find all columns which contain "DATE" in header (Such as : last machined date, assembly date, order date etc..) and change this format to date? Note: Needs to be dynamically because it might change from C:C to E:E in the future or more columns added.
Sub formatTable(ws As Worksheet)
On Error Resume Next
Dim lo As ListObject
Set lo = ws.ListObjects("FilterParts")
'Format the table
ws.UsedRange.Font.Bold = False
ws.UsedRange.Style = "Normal"
lo.TableStyle = "TableStyleMedium9"
'Format every column that has "DATE" in its header to a date column
'ws.Range("C:C").NumberFormat = "dd/mm/yyyy" and so on
End Sub
Just iterate through your columns like this, check if their names contain "Date" and if yes, then format them:
Set lo = ws.ListObjects("FilterParts")
For Each dataColumn In lo.ListColumns
If InStr(dataColumn.Name, "Date") > 0 Then
dataColumn.DataBodyRange.NumberFormat = "dd/mm/yyyy"
End If
Next dataColumn
Run this macro every time you add a new column.
A longer coding option but uses Find to avoid looping through the range.
Dim ws As Worksheet
Dim lo As ListObject
Dim rng1 As Range
Dim StrAddress As String
Set ws = ActiveSheet
Set lo = ws.ListObjects("FilterParts")
Set rng1 = lo.Range.Rows(1).Find("Date", , , xlPart)
If Not rng1 Is Nothing Then
StrAddress = rng1.Address
rng1.Offset(1, 0).Resize(lo.ListRows.Count, 1).NumberFormat = "dd/mm/yyyy"
Do
Set rng1 = lo.Range.Rows(1).Find("Date", rng1, , xlPart)
rng1.Offset(1, 0).Resize(lo.ListRows.Count, 1).NumberFormat = "dd/mm/yyyy"
Loop While StrAddress <> rng1.Address
End If
Dim HdrRow as range
Dim Cl as Range
Set HdrRow = ActiveSheet.UsedRange
Set HdrRow = HdrRow.Row(1) 'assuming row 1 of the data contains headers
For Each Cl In HdrRow.cells
If Instr(lCase(Cl.Value), "date") > 0 then 'This column has "date" in the header text
enter code here
Next Cl
from here you can either store the cell/column number for a loop later or loop the cells in this column right away....
this should get you started just post back if you need more help.
Try:
Range("A1","A50000").NumberFormat = "dd\/mm\/yyyy"
Related
The main goal is: Retrieve specific cell values from each row in a filtered table by using column reference name.
So far, I have the following code
Dim table As listObject
Dim columns As ListColumns
Dim row As ListRow
Dim rnData As range
Dim rngArea As range
Set table = Sheets(sheetName).ListObjects(TableName)
Set columns = table.ListColumns
Set rnData = ThisWorkbook.Worksheets(sheetName).ListObjects(TableName).range
'Notice that sheetName and TableName are function arguments. No need to pay attention. Consider any string values.
'Filter my table
table.range.AutoFilter Field:=7, Criteria1:=Array("filtervalue1", "filtervalue2"), Operator:=xlFilterValues
'Set the filtered table in a new Range object
Set rnData = ThisWorkbook.Worksheets(sheetName).ListObjects(TableName).range
'Count all rows of my filtered table
With rnData
For Each rngArea In .SpecialCells(xlCellTypeVisible).Areas
lCount = lCount + rngArea.Rows.Count
Next
End with
Now I want to loop my filtered table (my "rnData" range) and I want to get the cell value for each row in those Range.Areas.
I was thinking something like this, but i'm having difficulties with VBA to do this:
For iRowNo = 2 To (lCount - 1) 'Start at 2 because 1 is the table header
'This does not work once it gets another row from the entire table. Not the filtered one. Help here!
Set row = table.ListRows(iRowNo)
'Something close to this - Help Here!
Set row = rnData.SpecialCells(xlCellTypeVisible).Areas
''Would like to have the code like this to get the values
cell1Value= row.range(1, columns("My Column Header 1").Index).value
cell2Value= row.range(1, columns("My Column Header 2").Index).Value
Next iRowNo
Let me know if there are different solutions than this.
Following the #DirkReichel answer
Here is the code that worked for me:
Dim table As listObject
Dim columns As ListColumns
Dim row As ListRow
Dim rnData As range
Dim rngArea As range
Set table = Sheets(sheetName).ListObjects(TableName)
Set columns = table.ListColumns
Set rnData = ThisWorkbook.Worksheets(sheetName).ListObjects(TableName).range
'Notice that sheetName and TableName are function arguments. No need to pay attention. Consider any string values.
'Filter my table
table.range.AutoFilter Field:=7, Criteria1:=Array("filtervalue1", "filtervalue2"), Operator:=xlFilterValues
'Set the filtered table in a new Range object
Set rnData = ThisWorkbook.Worksheets(sheetName).ListObjects(TableName).range
'Get values for each row
With rnData
For Each rngArea In .SpecialCells(xlCellTypeVisible).Areas
For Each row In rngArea.Rows
cell1Value= row.range(1, columns("My Column Header 1").Index).value
cell2Value= row.range(1, columns("My Column Header 2").Index).Value
Next
'lCount = lCount + rngArea.Rows.Count 'Removed this.
Next
End with
'Also no need the second part of code with the For..Next loop.
I think you're indirectly trying to create an array which is not something that can be easily explained a single post, but here's some code to get you started.
I'm going to assume that your set rnData range is correct. From there, it's probably easiest to just loop through all cells in range. You could write code more precise than below, but this should help you see a couple ideas besides what you're trying.
Most important I think you're looking for a method to create an array. I hope this helps.
Sub testCoutinho()
Dim Rcell As Range
Dim rnData As Range 'you'll have to set this up...
Dim YesLetsDoAnArray As Boolean: YesLetsDoAnArray = False 'or change to false to just make a new sheet with values
If YesLetsDoAnArray Then
ReDim This_is_your_Array(0) As Variant 'Create Array
Dim x As Integer
Else
'putting values on a new worksheet in file
Dim CleanWS As Worksheet: Set CleanWS = ThisWorkbook.Sheets.Add
End If
For Each Rcell In rnData.Cells
If Rcell.EntireRow.Hidden = False Then
If YesLetsDoAnArray Then
ReDim Preserve This_is_your_Array(x)
This_is_your_Array(x) = Rcell.Value
x = x + 1
Else
CleanWS.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = Rcell.Value
End If
End If
Next Rcell
'If you used an array, you'll know have variable(s) that contain all your data.
'your first one is This This_Is_Your_Array(0), followed by This_Is_Your_Array(1)... etc.
'you can play around. this will print them all.
If YesLetsDoAnArray Then
Dim i As Integer
For i = 0 To x - 1
Debug.Print This_is_your_Array(i)
Next i
End If
End Sub
How to find location of last cell from defined Range? Cell does not have to contain any data but must be most right and most down located cell from certain Range.
Set rngOrigin = wksOrigin.Cells(IntFirstRow, IntFirstColumn).CurrentRegion
I wish to receive
Cells(i,j)
Perhaps this is what you want:
Dim rngLastCell As Range
Set rngLastCell = rngOrigin(rngOrigin.Count)
maybe you're after this:
'absolute indexes from cell A1
With rngOrigin
i = .Rows(.Rows.count).row
j = .Columns(.Columns.count).Column
End With
'relative indexes from rngOrigin upleftmost cell
With rngOrigin
i = .Rows(.Rows.count).row - .Rows(1).row + 1
j = .Columns(.Columns.count).Column - .Columns(1).Column + 1
End With
I handled it in below code but your remarks were helpful. Thank you.
intLastRow = rngOrigin.Cells(1, 1).Row + rngOrigin.Rows.Count - 1
intLastCol = rngOrigin.Cells(1, 1).Column + rngOrigin.Columns.Count - 1
The answers given by others mostly work, but not if the region is a union of non-contiguous cells. Here is a version that works consistently for single and multi-area regions, contiguous and non-contiguous.
Function LastCellOfRange(rng As Excel.Range) As Excel.Range
Dim area As Excel.Range
Dim rowNum As Long
Dim maxRow As Long
Dim colNum As Long
Dim maxCol As Long
Dim areaIdx As Integer
Set LastCellOfRange = Nothing
maxRow = 0
maxCol = 0
For areaIdx = 1 To rng.Areas.Count
Set area = rng.Areas(areaIdx)
rowNum = area.Cells(area.Cells.Count).row
If (rowNum > maxRow) Then
maxRow = rowNum
End If
colNum = area.Cells(area.Cells.Count).Column
If (colNum > maxCol) Then
maxCol = colNum
End If
Next areaIdx
Set LastCellOfRange = rng.Worksheet.Cells(maxRow, maxCol)
Set area = Nothing
End Function
Use this to code find the last cell in a given range
Sub GetLastCellFromRange()
Dim rng As Range
Set rng = Range("$C$10:$E$20")
'Set rng = Range(Selection.Address) ' Use this line to select the range in worksheet
MsgBox "Last Cell of given range is : " & rng.Cells(rng.Rows.Count, rng.Columns.Count).Address
End Sub
I hope it will help you
you could try the following but it relies upon cells always being populated
rngOrigin.End(xlDown).End(xlRight)
or you could use the CurrentRegion and count the rows and columns and use Offset
Alternatively, you could use this construct which works even with ranges based on entire rows or entire columns.
Sub Test()
Dim rngOrigin As Excel.Range
Set rngOrigin = Range("$A$1:$D$6")
Dim rngLast As Excel.Range
Set rngLast = rngOrigin.Cells(rngOrigin.Cells.Count)
Debug.Print rngLast.Address
End Sub
Finally, for ranges with multiple areas you'll have to script against a range's Areas collection ...
Sub Test()
Dim rngOrigin As Excel.Range
Set rngOrigin = Range("$A$1:$D$6,$F$1:$G$6")
Debug.Print rngOrigin.Areas(1).Cells(rngOrigin.Areas(1).Cells.Count).Address
Debug.Print rngOrigin.Areas(2).Cells(rngOrigin.Areas(2).Cells.Count).Address
End Sub
Many answers here will work as long as the given range is continuous. This is what I would use for a range that you are absolutely sure is going to be continuous:
Sub test()
Dim myRng As Range, lastCell As Range
Set myRng = Range("A1:D4")
Set lastCell = myRng.Cells(myRng.Rows.Count, myRng.Columns.Count)
Debug.Print lastCell.Address 'returns $D$4
End Sub
For non-continuous, DB user10082797 gave a great solution, however their function fails when the ranges are positioned diagonal-up (for example, if you pass rng=A3:B4,C1:D2 in you will get D4 as the output which was not part of the original range.)
So the question becomes, what is the last cell in the range A3:B4,C1:D2? Is it B4 or D2? That's a decision for the programmer. Here is a function I wrote with the help of DB user10082797's function:
Function LastCellOfRange(rng As Range, Optional returnLastRow As Boolean = True) As Range
'returns the last cell in #rng.
'if #returnLastRow is TRUE, then the output will always be in the right most cell of the last row of #rng
'if #returnLastRow is FALSE, then the output will always be in the bottom most cell of the last column of #rng
'(#returnLastRow only matters for non-contiguous ranges under certain circumstances.)
'initialize variables
Dim area As Range, areaIdx As Long
Dim lastCellInArea As Range
'loop thru each area in the selection
For areaIdx = 1 To rng.Areas.Count
Set area = rng.Areas(areaIdx) 'get next area
Set lastCellInArea = area.Cells(area.Rows.Count, area.Columns.Count) 'get the last cell in the area
'if:
' the return is empty
' OR if the last row needs to be returned and this row is larger than the last area's
' OR if the last row needs to be returned and this row is the same as the last area's but has a larger column
' OR if the last column needs to be returned and this column is larger than the last area's
' OR if the last column needs to be returned and this column is the same as the last area's but has a larger row
'THEN:
' make this cell the return range
If LastCellOfRange Is Nothing Then
Set LastCellOfRange = lastCellInArea '(must be seperate from the other statment when its not set to anything)
ElseIf _
returnLastRow = True And lastCellInArea.Row > LastCellOfRange.Row _
Or returnLastRow = True And lastCellInArea.Row = LastCellOfRange.Row And lastCellInArea.Column > LastCellOfRange.Column _
Or returnLastRow = False And lastCellInArea.Column > LastCellOfRange.Column _
Or returnLastRow = False And lastCellInArea.Column = LastCellOfRange.Column And lastCellInArea.Row > LastCellOfRange.Row _
Then
Set LastCellOfRange = lastCellInArea
End If
Next areaIdx
End Function
You can use the function like this:
Sub test()
Dim myRng As Range
Set myRng = Range("A3:B4,C1:D2")
Debug.Print LastCellOfRange(myRng).Address 'returns $B$4
Debug.Print LastCellOfRange(myRng, False).Address 'returns $D$2
End Sub
In your case, since you want to find the cell to the most right and down in your wksOrigin (defined as Worksheet), you could use the SpecialCells(xlCellTypeLastCell) to get the last cell Row and Column.
i = wksOrigin.Cells.SpecialCells(xlCellTypeLastCell).Row ' <-- get last row number
j = wksOrigin.Cells.SpecialCells(xlCellTypeLastCell).Column ' <-- get last column number
If you want to debug your result, you can add:
MsgBox "Last row at " & i & ", last column at " & j
If you want the absolute last cell of a defined range, regardless of whether it has any content, here is a simple solution
Dim InputRng As Range 'define a range for the test'
Set InputRng = Range("$F$3:$F$15")
MsgBox InputRng(1).Address & ":" & InputRng(InputRng.Cells.Count).Address 'This would output the absolute address of defined range'
I'm attempting to create a macro to do the following:
Search a spreadsheet column header by name.
Select all data from the selected column, except column header.
Take Number Stored As Text & Convert to Number.
Converting to Number to use for VLookup.
For Example:
Visual Spreadsheet Example:
I've discovered the following code online:
With ActiveSheet.UsedRange
Set c = .Find("Employee ID", LookIn:=xlValues)
If Not c Is Nothing Then
ActiveSheet.Range(c.Address).Offset(1, 0).Select
End If
End With
However, I'm still experiencing some issues.
I just stumbled upon this, for me the answer was pretty straightforward, in any case If you're dealing with a ListObject then this is the way to go:
YOURLISTOBJECT.HeaderRowRange.Cells.Find("A_VALUE").Column
It is good to avoid looping through all cells. If the data set grows the macro can become too slow. Using special cells and paste special operation of multiplying by 1 is an efficient way of accomplishing the task.
This works...
Dim SelRange As Range
Dim ColNum As Integer
Dim CWS As Worksheet, TmpWS As Worksheet
'Find the column number where the column header is
Set CWS = ActiveSheet
ColNum = Application.WorksheetFunction.Match("Employee ID", CWS.Rows(1), 0)
'Set the column range to work with
Set SelRange = CWS.Columns(ColNum)
'Add a worksheet to put '1' onto the clipboard, ensures no issues on activesheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set TmpWS = ThisWorkbook.Worksheets.Add
With TmpWS
.Cells(1, 1) = 1
.Cells(1, 1).Copy
End With
'Select none blank cells using special cells...much faster than looping through all cells
Set SelRange = SelRange.SpecialCells(xlCellTypeConstants, 23)
SelRange.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply
TmpWS.Delete
CWS.Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Try this out. Simply add all the column header names you want to find into the collection. I'm assuming you don't have more than 200 columns, if you do simply update the for i = 1 to 200 section to a larger number.
Public Sub FindAndConvert()
Dim i As Integer
Dim lastRow As Long
Dim myRng As Range
Dim mycell As Range
Dim MyColl As Collection
Dim myIterator As Variant
Set MyColl = New Collection
MyColl.Add "Some Value"
MyColl.Add "Another Value"
lastRow = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For i = 1 To 200
For Each myIterator In MyColl
If Cells(1, i) = myIterator Then
Set myRng = Range(Cells(2, i), Cells(lastRow, i))
For Each mycell In myRng
mycell.Value = Val(mycell.Value)
Next
End If
Next
Next
End Sub
Ok, here's a brief way of achieving your goal. First, locate the column that holds the Employee IDs. Then simply set the entire Column to be formatted as Number instead of Text?
With Worksheets(1) ' Change this sheet to the one you are using if not the first sheet
Set c = .Find("Employee ID", LookIn:=xlValues)
If Not c Is Nothing Then
' The column we want is c's Column.
Columns(c.Column).NumberFormat = 0
End If
End With
Add a dim for the range that you want:
Dim MyRng, RngStart, RngEnd as Range
Then change:
ActiveSheet.Range(c.Address).Offset(1, 0).Select
to the below so that all data in that column is found.
set RngStart = ActiveSheet.Cells(1, c.column)
set RngEnd = ActiveSheet.Cells(rows.count, c.column).end(xlup)
set MyRng = ActiveSheet.Range(RngStart & ":" & RngEnd)
Now you can play about with the data. If you want to paste this somewhere which is formatted as number:
MyRng.copy
Sheets("Wherever").Range("Wherever").pastespecial xlvalues
If you want to change the format of the cells you have now found (How to format column to number format in Excel sheet?) that is whole number format, if you want decimal points then use "number" instead of "0":
MyRng.NumberFormat = "0"
or the new destination:
Sheets("Wherever").Range("Wherever").NumberFormat = "0"
General formatting which matches exactly the convert to number function:
MyRng.NumberFormat = "General"
MyRng.Value = MyRng.Value
I have been struggling for a day and a half with my code. I have a spreadsheet with over 50 columns 18000 rows. I have been able to identify a smaller range of cells in column A defined by "AllEntRg" based on blank cells in column H(OpsCol). I'm stuck with my loops towards the bottom. For EntityRg, I am looping through each cell in "AllEntRg" and if it is Not found in Range CCRg which was defined in BudWb Wk4 Then I want to create a range of all of those cells. The next option, CostCRg, I want to define a range for all cells that ARE FOUND in CCrg.
I have tested this by selecting individual cells and it provides the results I'm looking for but when I have this in the loops I'm getting the following two results: For EntityRg, the range.address defined is the same as AllEntRg (this shouldn't be the case). For CostCRg, I'm getting an error. I'm not sure what I'm not defining correctly. I've been stuck here for quite a while and I have tried using Match Function as well. Again, individually it works but in the loop I'm getting these results which are not expected. I'm interested on the feedback I may receive. Thanks.
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim wb As Workbook
Dim BudWkb As Workbook
Dim Wk2 As Worksheet
Dim PNLWkb As Workbook
Dim fpath As String
Dim fname As String
Set BudWkb = Workbooks("SubModel Forecast_Other Admin v4.xlsm")
Set Wk2 = BudWkb.Sheets("By PM")
fname = "Feb15 PNL"
'fname = InputBox("Enter PNL File Name")
Dim Wk4 As Worksheet
Set Wk4 = BudWkb.Sheets("Validation")
With Wk4
Dim CCCol As Long
Dim fRowCC As Long
Dim lRowCC As Long
CCCol = Wk4.Cells.Find("Cost Center", lookat:=xlWhole).Column
fRowCC = Wk4.Cells.Find("Cost Center", lookat:=xlWhole).Offset(1, 0).row
lRowCC = Wk4.Cells.Find("Cost Center", lookat:=xlWhole).End(xlDown).row
Dim CCRg As Range
Set CCRg = Wk4.Range(Wk4.Cells(fRowCC, CCCol), Wk4.Cells(lRowCC, CCCol))
'MsgBox (CCRg.Address)
End With
Set PNLWkb = Workbooks("Feb15 PNL.xlsx")
Dim Wk1 As Worksheet
Set Wk1 = PNLWkb.Sheets("det")
With Wk1
If Left(Wk2.Name, 5) = "By PM" Then
Dim OpsCol As Long
OpsCol = Wk1.Cells.Find("Property Manager", lookat:=xlWhole).Column
Else
OpsCol = Wk1.Cells.Find("Submarket", lookat:=xlWhole).Column
End If
Dim FRow As Long
Dim lRow As Long
Dim ExpCol As Long
Dim PropCodeCol As Long
Dim Expense As String
Expense = InputBox("Enter Expense GL")
'to locate begining and ending row of data on PNL report
'Identifies the column where the SubMarket names are located for lookup purposes
'Defines the expense GL column to lookup based on the inputbox above
FRow = Wk1.Cells.Find("66990000", lookat:=xlPart).Offset(2, 0).row
lRow = Wk1.Cells.Find("66990000", lookat:=xlPart).End(xlDown).Offset(-1, 0).row
ExpCol = Wk1.Cells.Find(Expense, lookat:=xlPart).Column
PropCodeCol = Wk1.Cells.Find("Property Code", lookat:=xlWhole).Column
'Defines the Range of the PM or Sub-Market Names
Dim OpsRg As Range
Set OpsRg = Wk1.Range(Wk1.Cells(FRow, OpsCol), Wk1.Cells(lRow, OpsCol))
'Defines the Range of the Property Codes
Dim PropCodeRg As Range
Set PropCodeRg = Wk1.Range(Wk1.Cells(FRow, PropCodeCol), Wk1.Cells(lRow, PropCodeCol))
'Defines the exact range of the expense column being analyzed
Dim ExpRg As Range
Set ExpRg = Wk1.Range(Wk1.Cells(FRow, ExpCol), Wk1.Cells(lRow, ExpCol))
End With
Dim AllEntRg As Range
For Each Cell In OpsRg
If Cell = "" Then
If AllEntRg Is Nothing Then
Set AllEntRg = Cells(Cell.row, PropCodeCol)
Else
Set AllEntRg = Union(AllEntRg, Cells(Cell.row, PropCodeCol))
End If
'End If
End If
Next
MsgBox (AllEntRg.Address)
'MsgBox (Application.Match(Wk1.Cells(59, 1), CCRg, 0))
'Dim y
'y = Application.Match(Wk1.Cells(10, 1), CCRg, 0)
'If IsError(y) Then
'MsgBox ("pooopy error")
'End If
Dim EntityRg As Range
'Dim c As Range
For Each c In AllEntRg
'Dim z
'z = Application.Match(c, CCRg, 0)
If CCRg.Find(c.Value, lookat:=xlPart) Is Nothing Then
If EntityRg Is Nothing Then
Set EntityRg = c
Else
Set EntityRg = Union(EntityRg, c)
End If
End If
Next
MsgBox (EntityRg.Address)
Dim CostCRg As Range
Dim r As Range
For Each r In AllEntRg
If Not CCRg.Find(r.Value, lookat:=xlPart) Is Nothing Then
If CostCRg Is Nothing Then
Set CostCRg = r
Else
Set CostCRg = Union(CostCRg, r)
End If
End If
Next
MsgBox (CostCRg.Address)
Dim v As Double
v = Application.WorksheetFunction.Sum(EntityRg)
'SendKeys "{F9}"
MsgBox (v)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
I have no means of running your code but I have reviewed it and have noticed some possible problems.
lRowCC = Wk4.Cells.Find("Cost Center", lookat:=xlWhole).End(xlDown).row
`.End(xlDown) is not a reliable method of finding the last row of a column. Read this answer of mine for an explanation: Excel vba – xlDown
You say: “For EntityRg, the range.address defined is the same as AllEntRg (this shouldn't be the case).”
Do you believe they are the same because EntityRg.Address = AllEntRg.Address?
EntityRg .Address will be a string of absolute cell and range addresses separated by commas. You may not be aware that this string has a maximum length of about 255. I cannot find any documentation but from my own experimentation, EntityRg .Address will be truncated to less than 256 such that there is no partial cell or range address.
Are you being fooled by the first 255 characters of these addresses matching?
Another possibility is that every use of CCRg.Find(c.Value, lookat:=xlPart) returns Nothing so EntityRgand AllEntRg are equal. You say CostCRg gives an error; is this because it is Nothing?
You have two loops searching CCRg for values in AllEntRg. One loop records the successes and one records the failures. Why not combine the loops into something like:
If CCRg.Find(c.Value, lookat:=xlPart) Is Nothing Then
If EntityRg Is Nothing Then
Set EntityRg = c
Else
Set EntityRg = Union(EntityRg, c)
End If
Else
If CostCRg Is Nothing Then
Set CostCRg = r
Else
Set CostCRg = Union(CostCRg, r)
End If
End If
I am concerned that For Each c In AllEntRg is not giving you what you expect. If you combine ranges with Union, it will tidy them up. So Union(Range("A2"), Range("A3", Range("A5"), Range("A6"), Range("A7")).Address is
"$A$2:$A$3,$A$5:$A$7" not "$A$2,$A$3,$A$5,$A$6,$A$7". My recollection is that For Each c In AllEntRg would not split "$A$2:$A$3" into separate cells.
Please use F8 to step through this loop to check that it is performing as you expect.
Hope this helps
Answer to problem described in comment
Your problem is you are not being consistent in you use of Withs and, in particular, you are not identifying which workbook you want to operate on.
Wk4 is explicitly specified to be within workbook BufdWkb and Wk1 is specified to be within PNLWkb.
However, in
Set AllEntRg = Cells(Cell.row, PropCodeCol)
you do not specify a worksheet or workbook for Cells. This is the equivalent of
Set AllEntRg = ActiveWorkbook.ActiveSheet.Cells(Cell.row, PropCodeCol)`
You need to write Set AllEntRg = .Cells(Cell.row, PropCodeCol) (note period before Cells) and include this code within the With Wk1 Block.
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