I'm looking for a way to loop through the third column of each row of a table.
If that cell is blank, it should shade the entire row
If that cell is occupied, it should look for any spaces and replace all spaces with a single # (for example 123 abc becomes 123#abc).
It should not run on the header row of the table.
Some random items-
the worksheet name is Quote
table name is QuoteTable
shading should be RGB(255, 248, 220)
The number of rows in the table will always vary, but the macro will always be checking the contents of the third column of the table which is named Model #.
Thanks for the responses, I will try each one, and in the meantime I came up with this--- which does everything except it highlights every single row from A-N not just the correct ones.
Public Sub ValidateSKUs()
Dim sMfrPN As String
Dim tbl1 As Range
Dim myCell As Range
Set tbl1 = Sheets("Quote").Range("QuoteTable")
For Each myCell In tbl1.Columns(3).Cells
If myCell.Value = "" Then
Sheets("Quote").Range("A" & myCell & ":N" & myCell).Interior.Color = RGB(255, 248, 220)
Sheets("Quote").Range("A" & myCell & ":N" & myCell).Interior.Pattern = xlSolid
Else
sMfrPN = CleanUpPN(myCell)
myCell = sMfrPN
End If
Next
End Sub
Public Function CleanUpPN(ByVal sMfrPN As String) As String
Dim sPN As String
'Trim trailing spaces
sPN = Trim(sMfrPN)
'Replace space with #
sPN = Replace(sPN, " ", "#")
'remove multiple # (e.g. ##)
Do Until InStr(1, sPN, "##") = 0
sPN = Replace(sPN, "##", "#")
Loop
CleanUpPN = sPN
End Function
VBA coding for a structured table can be a pain. You can either deal with the table as a ListObject object or Set a Range object variable to the .DataBodyRange property and deal with the cell addresses as you would with any other worksheet reference.
Sub fix_model_no()
Dim mn As Range
With Worksheets("Sheet1") '<~~ set this properly!
With .ListObjects("QuoteTable")
For Each mn In Range("QuoteTable[Model '#]")
If Len(Trim(mn.Value2)) Then
Intersect(.DataBodyRange, Rows(mn.Row)).Interior.ColorIndex = xlColorIndexNone
mn = Replace(Application.Trim(mn.Value2), Chr(32), Chr(35))
Else
mn.ClearContents
Intersect(.DataBodyRange, Rows(mn.Row)).Interior.ColorIndex = 3 'red
End If
Next mn
End With
End With
End Sub
The single tick in QuoteTable[Model '#] is necessary to reference the Model # column. Any reference to a ListObject table likes to know which worksheet the table resides on.
You may wish to consider Conditional Formatting for the row highlighting based upon the blank cells in column C.
Change "Z" to whatever column you require
Sub Oh_Ya()
Dim sh As Worksheet
Dim rng As Range, c As Range
Dim rws As Long, r
Set sh = Sheets("Quote")
With sh
rws = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("C2:C" & rws)
For Each c In rng.Cells
c = Replace(c, " ", "#")
If c = "" Then
r = c.Row
Range("A" & r & ":Z" & r).Interior.Color = RGB(255, 248, 220)
End If
Next c
End With
End Sub
Related
I have a spreadsheet with values starting at A5 and running across to column AI, there could be any number of entries to the rows.
Row A contains an Item code (e.g. 000-0000)
I am looking to produce some code to complete the following two actions:
If column AI = yes, then copy entire row and paste below. With every copy add a sequential alphabetised letter to the code in column A (e.g. 000-0000a)
Any help would be greatly appreciated. Everything i've found expands to copying to another sheet and i'm struggling to break down the code.
Thanks
Edit:
Please see below current code I have been trying to get to work which works up to the point of copying the row however fails to paste it.
Sub NewItems(c As Range)
Dim objWorksheet As Worksheet
Dim rngNewItems As Range
Dim rngCell As Range
Dim strPasteToSheet As String
'Used for the new worksheet we are pasting into
Dim objNewSheet As Worksheet
Dim rngNextAvailbleRow As Range
'Define the worksheet with our data
Set objWorksheet = ThisWorkbook.Sheets("Sheet1")
'Dynamically define the range to the last cell.
'This doesn't include and error handling e.g. null cells
'If we are not starting in A1, then change as appropriate
Set rngNewItems = objWorksheet.Range("A5:A" & objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row)
'Now loop through all the cells in the range
For Each rngCell In rngNewItems.Cells
objWorksheet.Select
If rngCell.Value <> "Yes" Then
'select the entire row
rngCell.EntireRow.Select
'copy the selection
Selection.Copy
'Now identify and select the new sheet to paste into
Set objNewSheet = ThisWorkbook.Sheets("Sheet1" & rngCell.Value)
objNewSheet.Select
'Looking at your initial question, I believe you are trying to find the next available row
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
End If
Next rngCell
objWorksheet.Select
objWorksheet.Cells(1, 1).Select
'Can do some basic error handing here
'kill all objects
If IsObject(objWorksheet) Then Set objWorksheet = Nothing
If IsObject(rngBurnDown) Then Set rngNewItems = Nothing
If IsObject(rngCell) Then Set rngCell = Nothing
If IsObject(objNewSheet) Then Set objNewSheet = Nothing
If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing
End Sub
So there are lots of things to address with your code. Many of which I have touched on. But the main thing to observe is that you are testing Column A not Column AI for the presence of "Yes" - so there may not be a match hence no copy.
As the paste destination is determined by a concatenation to create a sheet name you should have a test to ensure that sheet exists.
For testing I simply ensured a sheet called Sheet1a existed, that Sheet1 cell A5 had "a" in it, and there was a "Yes" in column AI. This could be improved but is enough to get you going.
This line is looping column A:
Set rngNewItems = objWorksheet.Range("A5:A" & lastRow)
Whereas this line is testing column AI:
If rngCell.Offset(, 35).Value <> "Yes"
Note <> means Not Equal as opposed to =
So perhaps you wanted:
If rngCell.Offset(, 35).Value = "Yes"
Consider the following re-write.
Option Explicit
Public Sub NewItems() 'c As Range) 'I have commented out parameter which isn't currently used.
Dim rngBurnDown As Range ' not used but also not declared
Dim objWorksheet As Worksheet
Dim rngNewItems As Range
Dim rngCell As Range
Dim strPasteToSheet As String
Dim objNewSheet As Worksheet
Dim lastRowTargetSheet As Long
Set objWorksheet = ThisWorkbook.Sheets("Sheet1")
Dim lastRow As Long
lastRow = objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row
Set rngNewItems = objWorksheet.Range("A5:A" & lastRow)
Dim copiedRange As Range 'for union
For Each rngCell In rngNewItems.Cells
'Debug.Print rngCell.Address 'shows where looping
If rngCell.Offset(, 35).Value = "Yes" Then
Set objNewSheet = ThisWorkbook.Sheets("Sheet1" & rngCell.Value)
Dim nextTargetCell As Range
lastRowTargetSheet = objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row
Set nextTargetCell = objNewSheet.Range("A" & lastRowTargetSheet)
rngCell.EntireRow.Copy nextTargetCell
Set objNewSheet = Nothing 'clear inside loop as you are setting in loop
lastRowTargetSheet = 0
Set nextTargetCell = Nothing
End If
Next rngCell
objWorksheet.Cells(1, 1).Select
End Sub
As for your lettering:
There are lots of examples online to generate these. Here is one way, by #harfang, from here:
Sub List_A_to_ZZZZ()
Dim i As Long
For i = 1 To 20 ' I have shortened this QHarr. Original end was 475254 ' ColXL("ZZZZ")
Debug.Print Right("---" & XLcL(i), 4)
Next i
End Sub
Function XLcL(ByVal N As Long) As String
Do While N > 0
XLcL = Chr(vbKeyA + (N - 1) Mod 26) & XLcL
N = (N - 1) \ 26
Loop
End Function
Function ColXL(ByVal abc As String) As Long
abc = Trim(Replace(UCase(abc), "-", ""))
Do While Len(abc)
ColXL = ColXL * 26 + (Asc(abc) - vbKeyA + 1)
abc = Mid(abc, 2)
Loop
End Function
I would like to copy column from excel "Book1" to another excel "Book2" by determined its cell value.
Let's say the header columns in Book1 are Name, Age, Gender, Address and Group. I want to copy the column "Name", "Age" and "Group" to "Book2". Below coding is what I've done to pull column data by cell coordinate.
Is it possible if I can pull the column from its header value?
Sub copyColumns()
Dim lr As Long, r As Long
Set src = ThisWorkbook.Worksheets("Sheet1")
Set tgt = Workbooks("Book2.xlsx").Worksheets("Sheet1")
lr = src.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
src.Cells(i, 1).copy
r = tgt.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
src.Paste Destination:=tgt.Cells(r, 1)
src.Cells(i, 2).copy
src.Paste Destination:=tgt.Cells(r, 2)
src.Cells(i, 5).copy
src.Paste Destination:=tgt.Cells(r, 3)
Next i
End Sub
There is number of solutions to this problem. For example, declare variables:
Dim rw As Range
Dim cl As Range
Dim sFields As String
Dim V
Dim j As Integer
Chose your column names for copying:
sFields = "Name|Age|Group"
V = Split(sFields, "|")
And then, inside your For i loop, make two another loops:
For Each cl In Intersect(src.Rows(i), src.UsedRange)
For j = 0 To UBound(V)
If cl.EntireColumn.Range("A1") = V(j) Then
tgt.Cells(i, j).Value = src.Cells(i, j).Value
End If
Next j
Next cl
Intersect(src.Rows(i), src.UsedRange) will chose all cells in row in the range that is actually used (that is, it will not loop through all 16 384 columns. All columns names are in one variable sFields, you can easily modify it. It is string separated with pipes, you will probably never use pipes (|) in your field names, so it is safe.
A few tips along the way:
Always declare every variable you want to use and user Option Explicit at the beginning of your module.
Dont copy every single cell, copy a range
See the updated code below:
Sub copyColumns2()
Dim src As Worksheet, tgt As Worksheet
Dim lr As Long, r As Long, I As Long, Col As Long
Dim ColsToCopy, ColToCopy, counter As Integer
ColsToCopy = Array("Name", "Age", "Group")
Set src = ThisWorkbook.Worksheets("Sheet1")
Set tgt = Workbooks("Book2.xlsx").Worksheets("Sheet1")
lr = src.Cells(Rows.Count, 1).End(xlUp).Row
For Col = 1 To 20
For Each ColToCopy In ColsToCopy
If src.Cells(2, Col).Value = ColToCopy Then
counter = counter + 1
src.Range(src.Cells(2, Col), src.Cells(lr, Col)).Copy tgt.Cells(2, counter)
Exit For
End If
Next ColToCopy
Next Col
End Sub
If you would like to copy the column by column header, you can use this function to get the letter of your header:
Function Letter(oSheet As Worksheet, name As String, Optional num As Integer)
If num = 0 Then num = 1
Letter = Application.Match(name, oSheet.Rows(num), 0)
Letter = Split(Cells(, Letter).Address, "$")(1)
End Function
Implementation:
Sub copycolum()
Dim ws As Worksheet, ws2 As Worksheet
Set ws = Sheets("Sheet1"): Set ws2 = Sheets("Sheet2"):
ws.Range(Letter(ws, "Gender") & "2:" & Letter(ws, "Gender") & ws.Range(Letter(ws, "Gender") & "1000000").End(xlUp).Row).Copy Destination:=ws2.Range(Letter(ws2, "Gender") & "2")
End Sub
Note that the function is set to default at row 1, in other words your header is in column 1, if you like you can change this to whatever row your data is in.
I have the following case:
1.Column D populated with about 100 values,
2. Using these I create a validation in the Column A cells
3. If I have a value in Cell "A1", this particular value should not appear
in Cell "A2" dropdown list, now the values in "A1" and "A2" should not appear in "A3" and so on.
What should be the thought process to write the VBA code for this?
I found this one interesting, so check this out... Should work as you expect it...
Post this code into your Worksheet and adapt it for your needs (if necessary). Hope it helps.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim dict As Object
Dim dictAlreadyTaken As Object
Dim valueRange As Range
Dim targetRange As Range
Dim cell As Object
Dim Key As Variant
Dim currentList() As Variant
Dim i As Integer
If Target.Column = 1 Then
Set ws = Worksheets(1)
Set dict = CreateObject("Scripting.Dictionary")
Set dictAlreadyTaken = CreateObject("Scripting.Dictionary")
Set valueRange = ws.Range("D:D")
Set targetRange = ws.Range("A:A")
For Each cell In valueRange
If cell.Value <> "" Then
dict.Add cell.Value, cell.Row
Else
Exit For
End If
Next cell
For Each cell In targetRange
If cell.Row <= dict.Count Then
If cell.Value <> "" Then
'ad the value taken
dictAlreadyTaken.Add cell.Value, cell.Row
End If
Else
Exit For
End If
Next cell
For Each cell In targetRange
If cell.Row <= dict.Count Then
'add this list
Erase currentList
ReDim currentList(0)
i = 0
ws.Cells(cell.Row, 1).Validation.Delete
For Each Key In dict.keys
If Not dictAlreadyTaken.exists(Key) Then
i = i + 1
ReDim Preserve currentList(i) As Variant
currentList(i) = Key
End If
Next Key
If UBound(currentList) > 0 Then
ws.Cells(cell.Row, 1).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(currentList, ",")
End If
Else
Exit For
End If
Next cell
End If
End Sub
My thought process would be:
First loop to list all the ranges we need to compare:
Cells(1,1) should not appear in Range(Cells(1,4),Cells(1,4))
Cells(2,1) should not appear in Range(Cells(1,4),Cells(2,4))
Cells(3,1) should not appear in Range(Cells(1,4),Cells(3,4)) ...etc...
Easy enough. Now that we know what ranges to compare, loop through the comparisons:
re: Cells(3,1) should not appear in Range(Cells(1,4),Cells(3,4)) :
.
Dim c as range
For Each c in Range(Cells(1,4),Cells(3,4))
If c.Value = Cells(1,4).Value then
'it's a match! Delete it (or whatever)
c.Value = ""
End If
Next c
Finally, put the two loops together...
From what I understand of your description, I came up with this:
Sub compareCells()
Dim c As Range, x As Integer
For x = 1 To 10
Debug.Print "Cells(" & x & ",1) should not appear in Range(Cells(1,4),Cells(" & x & ",4))"
For Each c In Range(Cells(1, 4), Cells(x, 4))
Debug.Print "compare " & Cells(x, 1).Address & " to " & c.Address
If Cells(x, 1).Value = c.Value Then
Cells(x, 1).Cells.Font.Color = vbBlue
End If
Next c
Next x
End Sub
It should be easily adaptable to your needs, or if not, there are plenty of existing solutions & resources, even a Stack Overflow tag: cascadingdropdown
Here is an approach:
Select a column in your sheet that you can use for a named range (this column can be hidden). For the purpose of example below, I've used column J and my named range is called ValidationRange. I have also assumed that the values in your worksheet start from row 2.
Now in a module, add the following sub:
Sub SetDropDownRange()
Dim oNa As Name: Set oNa = ThisWorkbook.Names.Item("ValidationRange")
Dim iLR&, iC&, iLRJ&
Dim aDRange As Variant
Dim aVRRange As Variant
With ThisWorkbook.Worksheets("Sheet12")
iLR = .Range("D" & .Rows.count).End(xlUp).Row
iLRJ = .Range("J" & .Rows.count).End(xlUp).Row
aDRange = Range("D2:D" & iLR)
For iC = LBound(aDRange) To UBound(aDRange)
If Len(Trim(aDRange(iC, 1))) <> 0 Then
If Application.WorksheetFunction.CountIf(Range("A:A"), aDRange(iC, 1)) = 0 Then
If IsArray(aVRRange) Then
ReDim Preserve aVRRange(UBound(aVRRange) + 1)
Else
ReDim aVRRange(0)
End If
aVRRange(UBound(aVRRange)) = aDRange(iC, 1)
End If
End If
Next
End With
Range("J2:J" & iLRJ).Value = ""
Range("J2:J" & UBound(aVRRange) + 2).Value = Application.Transpose(aVRRange)
oNa.RefersTo = oNa.RefersToRange.Resize(UBound(aVRRange) + 1, 1)
End Sub
Now call this function when something changes in your worksheet.. like so:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Or Target.Column = 4 Then
SetDropDownRange
End If
End Sub
Set Data Validation for the cells in column A using the named range (which is ValidationRange for this example)
Now everytime your select a value in column A, it will remove that value from the named range and hence from your dropdown box
I have the following code so far based on questions asked by other people.
I have a set of names listed in column A, and 216 columns and 9725 rows of data.
Currently using the following code I get the new sheets created except along with the unique names and its relevant data I get many cells filled with "#N/A".
In certain cases, the name Bob for example will be populated in a new sheet called Bob but the first column will have Bob and all relevant data and once all Bobs rows are shown it is follower with many rows with #N/A and all columns with #N/A.
In other cases the sheet will be created for Charles and all of Charles data will be listed, then many rows of #N/A and then all of the master-data including other peoples names which I need to avoid.
I want each individual sheet to only have the info based on the name of the person on that sheet. All of the data gets copied as I verified the number of accurate cells that get populated yet I get these #N/A cells and duplicated extra data and I'm not sure how to stop it from being populated? Any help in cleaning the code would be appreciated!!
Code:
Sub CopyDataFromReportToIndividualSheets()
Dim ws As Worksheet
Set ws = Sheets("FormulaMSheet2")
Dim LastRow As Long
Dim MyRange As Range
Worksheets("FormulaMSheet2").Activate
LastRow = Range("A" & ws.Rows.Count).End(xlUp).Row
' stop processing if we don't have any data
If LastRow < 2 Then Exit Sub
Application.ScreenUpdating = False
' SortMasterList LastRow, ws
CopyDataToSheets LastRow, ws
ws.Select
Application.ScreenUpdating = True
End Sub
Sub SortMasterList(LastRow As Long, ws As Worksheet)
ws.Range("A2:BO" & LastRow).Sort Key1:=ws.Range("A1")
', Key2:=ws.Range("B1")
End Sub
Sub CopyDataToSheets(LastRow As Long, src As Worksheet)
Dim allAgentNameCells As Range
Dim cell As Range
Dim Series As String
Dim SeriesStart As Long
Dim SeriesLast As Long
Set allAgentNameCells = Range("A2:A" & LastRow)
SeriesStart = 2
Series = Range("A" & SeriesStart).Value
For Each cell In allAgentNameCells
If cell.Value <> " " And cell.Value <> "" Then
' Condition ` And cell.Value <> "" ` added for my testdata. If you don't need this, please remove.
' Current Row's Series not SPACE
If cell.Value <> Series Then
SeriesLast = cell.Row - 1
CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
Series = cell.Value
SeriesStart = cell.Row
End If
End If
Next
'' copy the last series
SeriesLast = LastRow
CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
End Sub
Sub CopySeriesToNewSheet(src As Worksheet, Start As Long, Last As Long, name As String)
Dim tgt As Worksheet
Dim MyRange As Range
If (SheetExists(name)) Then
MsgBox "Sheet " & name & " already exists. " _
& "Please delete or move existing sheets before" _
& " copying data from the Master List.", vbCritical, _
"Time Series Parser"
End
Else
If Series = " " Then
End
End If
End If
Worksheets("FormulaMSheet2").Activate
' Worksheets.Add(after:=Worksheets(Worksheets.Count)).name = name
Worksheets("FormulaMSheet2").Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.name = name
Set tgt = Sheets(name)
' copy data from src to tgt
tgt.Range("A2:BO2" & Last - Start + 2).Value = src.Range("A" & Start & ":BO" & Last).Value
End Sub
Function SheetExists(name As String) As Boolean
Dim ws As Variant
For Each ws In ThisWorkbook.Sheets
If ws.name = name Then
SheetExists = True
Exit Function
End If
Next
SheetExists = False
End Function
You need replace the
tgt.Range("A2:BO2" & Last - Start + 2).Value = src.Range("A" & Start & ":BO" & Last).Value
to
src.Range("A" & Start & ":BO" & Last).SpecialCells(xlCellTypeVisible).Copy Destination:=tgt.Range("A2:BO2" & Last - Start + 2)
I found what I needed at the following site: http://www.rondebruin.nl/win/s3/win006_5.htm .
I figured if anyone else was looking for similar code it would help taking a look at the site.
Looking for help regarding writing a loop that will combine all the text values in a column while adding "OR" in between each one. To give some context, I have filenames stored in a column and I want to write a macro that will combine all those filenames separated by "OR" so I can copy and paste the string into a windows search bar and find all those files in a folder.
For example (in Column A)
Apples
Oranges
Bananas
Pears
Blueberries
In B1, the result should be Apples OR Oranges OR Bananas OR Pears OR Blueberries.
While learning to use For and Do loops in VBA is an essential skill, you will find that looping over ranges of cells is slow, and often too slow to be useful. There is often an alternative, and in this case it's the Join function:
Function MergeColumn(rng As Range, Delimiter As String) As Variant
MergeColumn = Join(Application.Transpose(rng.Columns(1).Value), Delimiter)
End Function
How this works:
It's a UDF, so it can be called from other VBA code, or from a worksheet cell
You pass it a Range object. It processes only the left most column of that Range
rng.Columns(1).Value returns the left most column, as a 2D Variant Array, size n x 1 where n is the number of rows in rng. That is, its dimension is 1 to n, 1 to 1
Application.Transpose transposes the array. It has the added feature that when passed a n x 1 array it returns a 1D array length n. That is, its dimension is 1 to n
Join concatenates each member of the array, inserting Delimiter between each element.
Use it like this
In VBA
Sub Demo
Dim r as Range
Dim strResult as String
' Get a reference to the range to be processed, eg
Set r = Range("A1:A10")
' Call the function
strResult = MergeColumn(r, " OR ")
' Print Result to Imedieate window
Debug.Print strResult
End Sub
As a cell formula
=MergeText(A1:A10," OR ")
here is a simple example using For Each Loop
Dim cel as Range, rng as Range
Set rng = Range("A1","A5")
For Each cel in rng
With Range("B1")
If .Value = "" Then
.Value = cel
Else
.Value = .Value & "OR" & cel
End If
End With
Next
Using simple For Loop:
Dim rng as Range, i as integer
Set rng = Range("A1", "A5")
For i = 1 to rng.Rows.Count
With Range("B1")
If .Value = "" Then
.Value = rng.Range("A" & i)
Else
.Value = .Value & "OR" & rng.Range("A" & i)
End If
End With
Next
Using Do Loop
Dim rng as Range, i as integer
Set rng = Range("A1", "A5")
i = 1
Do Until i > rng.Rows.Count
With Range("B1")
If .Value = "" Then
.Value = rng.Range("A" & i)
Else
.Value = .Value & "OR" & rng.Range("A" & i)
End If
End With
i = i + 1
Loop
Hope this helps.
With a formula (assuming Apples is in A2 and B1 is blank):
=IF(ISBLANK(B1),A2,B1&" OR "&A2)
copied down to suit (and output in last row).
A simple solution. Feel free to modify the code.
I did not include much flexibility such as count last row.
Just a basic template to show you how to use for loop.
for li_row = 1 to 10
if str_file = '' then
str_file = cells(li_row,1).value
else
str_file = str_file + ' OR ' + cells(li_row,1).value
end if
next
cells(1,2).value = str_file
One more method ..it works upto last used row in column A
Tested
Sub testing()
Dim lrow As Integer
Dim erange As Range
Dim str As String
With ActiveSheet
lrow = .Range("A" & Rows.Count).End(xlUp).Row
str = ""
For Each erange In .Range("A2:A" & lrow)
If str = "" Then
str = erange.Value
Else
str = str & " OR " & erange.Value
End If
Next erange
MsgBox (str)
End With
End Sub