These are my merged cells
I would like to loop though these merged cells, find the end of every merged cell and then Border Around on the left with Dots(xlDots) till ROW6
This would be my output
Here is what I tried until now
Dim rng As Range
Set rng = Range("A1:I6")
With rng.Borders
.LineStyle = xlDot
.Weight = xlThin
End With
But it borders me every cell, can I give a STEP 2 like in a for loop?
Here is variation on #JvdV answer.
For Each cel In ThisWorkbook.Sheets("Sheet1").Range("A3:M3") 'change sheet as needed
If cel.MergeCells = True Then
With cel.MergeArea.Offset(1).Resize(3).Borders(xlEdgeLeft)
.LineStyle = xlDash
End With
End If
Next cel
My suggestion is based of a trick seen here
Sub Test()
Dim rng As Range, cl As Range
With Sheet1 'Change appropriately
Set rng = Intersect(.Cells.SpecialCells(2), .Cells.SpecialCells(4))
For Each cl In rng
If cl.MergeArea.Row = 3 Then
cl.MergeArea.Offset(1).Resize(3, cl.MergeArea.Columns.Count).Borders(xlEdgeLeft).LineStyle = xlDot
End If
Next cl
End With
End Sub
.Intersect creates a range out of all cells that are part of merged areas through the use of .SpecialCells. I used a combination of constants and blanks (indexes 2 and 4 respectively) but if your values are a result of formulas you can change that to -4123 and 4.
I made sure these cells are part of a .MergeArea that starts at row 3.
Then simply .Offset by 1 row and .Resize that range object up to row 6 and the actual width of the merged area (using Columns.Count) since you might not be 100% sure about the width of columns of these merged areas.
You can set the xlEdgeLeft border's linestyle right there to xlDot.
Obviously, if your range of merged cells only involves column A-I it would get a lot more simple, while this solution is a bit more dynamic in that sense.
As an alternative, you don't need VBA. You can use Conditional Formatting:
Rule:
=AND(A$3<>"",B$3="",C$3="")
Applies to Range:
=$C$4:$I$6
And of course just choose the format as desired.
Related
I have a problem with referencing to other cells in my sheet. I have a VBA that creates tables out of a pivot table and saves them on different sheets. Example of the table:
The number of rows for any name can change, the total row position can therefore change too. I needed to bold the whole subtotal and total rows
(in this case it would be B9:G9, B12:G12, B14:G14, A15:G15) so I tried this:
If Right(cell.Value, 5) Like "Total" Then
With cell
.HorizontalAlignment = xlLeft
.Font.Bold = True
End With
End If
Next cell
which naturally only bolded the one cell which has the 'Total' text in it. The problem is referencing to the other cells in the rows I want to bold - the merged cells are messing that up. When I tried this:
cell.EntireRow.Font.Bold = True
the whole Project got bold (A5:G14). I also tried the offset function, but offset(0,1) sent me to cell C5.
Do you please have any idea how to make the whole total and subtotal rows bold?
Thanks,
B.
You could do something like this:
Sub Tester()
Dim ws As Worksheet, c As Range
Set ws = ActiveSheet
For Each c In ActiveSheet.UsedRange.Cells
If c.Value Like "*Total" Then
'from cell with "*Total" to last column
With ws.Range(c, ws.Cells(c.Row, "G"))
.HorizontalAlignment = xlLeft
.Font.Bold = True
End With
End If
Next c
End Sub
Is it possible to write a vba macro that determines if there are any empty cells in a given range and returns the row number of that cell?
I'm new to vba and all that I managed to write after searching the internet was something that takes a range and colors every emty cell in it red:
Sub EmptyRed()
If TypeName(Selection) <> "Range" Then Exit Sub
For Each cell In Selection
If IsEmpty(cell.Value) Then cell.Interior.Color = RGB(255, 0, 0)
Next cell
End Sub
The macro does basically what I want, but instead of coloring the empty cell red I would like to know the row index of the empty cell.
A little background info: I have a very large file (about 80 000 rows) that contains many merged cells. I want to import it into R with readxl. Readxl splits merged cells, puts the value in the first split cell and NA into all others. But a completely empty cell would also be assigned NA, so I thought the best thing would be to find out which cells are empty with Excel, so that I know which NA indicate a merged cell or an empty cell. Any suggestions on how to solve this problem are very welcome, thanks!
Edit: To clarify: Ideally, I want to unmerge all cells in my document and fill each split cell with the content of the previously merged cell. But I found macros on the web that are supposed to do exactly that, but they didn't work on my file, so I thought I could just determine blank cells and then work on them in R. I usually don't work with Excel so I know very little about it, so sorry if my thought process is far too complicated.
To do exactly what you state in your title:
If IsEmpty(cell.Value) Then Debug.Print cell.Row
But there are also Excel methods to determine merged cells and act on them. So And I'm not sure exactly what you want to do with the information.
EDIT
Adding on what you say you want to do with the results, perhaps this VBA code might help:
Option Explicit
Sub EmptyRed()
Dim myMergedRange As Range, myCell As Range, myMergedCell As Range
Dim rngProcess As Range
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Set rngProcess = Range("A1:B10")
For Each myCell In rngProcess
If myCell.MergeCells = True Then
Set myMergedRange = myCell.MergeArea
With myMergedRange
.MergeCells = False
.Value = myCell(1, 1)
End With
End If
Next myCell
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End sub
Note that I explicitly declare all variables, and I hard coded the range to check. There are various ways of declaring the range to be checked; using 'Selection' is usually rarely preferred.
Before anything else: From the opposite end of the spectrum, you can use Range.MergeCells or Range.MergeArea to determine if a Cell is part of a Merged Area. But, I digress...
You can use Cell.Row to get the row number. How you return or display that is up to you - could be a Message Box, a delimited string, or an array, or even a multi-area range.
A Sub cannot return anything once called, so you may want a Function instead, e.g. Public Function EmptyRed() As String
(Also, I would recommend you get in the habit of explicitly declaring all of your variables, and perhaps using Option Explicit too, before you run into a typo-based error. Just add Dim cell As Range at the top of the sub for now)
Sub FF()
Dim r, wksOutput As Worksheet
Dim cell As Range, rng As Range, rngArea As Range
With Selection
.UnMerge
'// Get only blank cells
Set rng = .SpecialCells(xlCellTypeBlanks)
'// Make blank cells red
rng.Interior.Color = vbRed
End With
'// Create output worksheet
Set wksOutput = Sheets.Add()
With wksOutput
For Each rngArea In rng.Areas
For Each cell In rngArea
r = r + 1
'// Write down the row of blank cell
.Cells(r, 1) = cell.Row
Next
Next
'// Remove duplicates
.Range("A:A").RemoveDuplicates Array(1), xlNo
End With
End Sub
There are a couple ways:
Sub EmptyRed()
Dim rgn,targetrgn as range
Dim ads as string ‘ return rgn address
Set targetrgn= ‘ your selection
For Each rgn In Targetrgn
If IsEmpty(rgn.Value) Then
‘1. Use address function, and from there you can stripe out the column and row
Ads=application.worksheetfunction.addres(cell,1)’ the second input control the address format, w/o $
‘2. Range.row & range.column
Ads=“row:” & rgn.row & “, col: “ & rgn.column
End if
Next rgn
End Sub
Ps: I edited the code on my phone and will debug further when I have a computer. And I am just more used to use “range” rather than “cell”.
To clarify: Ideally, I want to unmerge all cells in my document and fill each split cell with the content of the previously merged cell.
Cycle through all cells in the worksheet's UsedRange
If merged, unmerge and fill the unmerged area with the value from the formerly merged area.
If not merged but blank, collect for address output.
Sub fillMerged()
Dim r As Range, br As Range, mr As Range
For Each r In ActiveSheet.UsedRange
If r.Address <> r.MergeArea.Address Then
'merged cells - unmerge and set value to all
Set mr = r.MergeArea
r.UnMerge
mr.Value = mr.Cells(1).Value
ElseIf IsEmpty(r) Then
'unmerged blank cell
If br Is Nothing Then
Set br = r
Else
Set br = Union(br, r)
End If
End If
Next r
Debug.Print "blank cells: " & br.Address(0, 0)
End Sub
So I'm working on an excel sheet, and this is something i really can't figure out.
I want it to be that if the contents of a cell match certain criteria, an entire column of cells will be pasted according to that cell. The cell is a drop down with 32 different options (that can be reduced if theres no way to do it) and each option corresponds to a different column of data. The columns that have to be pasted have roughly 32 cells of data each.
My current formula is basically =IFS(A1="Potato",Sheet2!G:G) but this gives me a '0'. The best i can do is change the formula to =IFS(A1="Potato",Sheet2!G1) or =IFS(A1="Potato",Sheet2!G1:G32) but both of these formulas give me the contents of the first cell only (G1).
Any ideas on how I could get this done without having to contact aliens or build a spaceship?
You can use formulas, or VBA.
I have assumed your 32 columns of source data are in Sheet2 with the headers in row 1.
Formula Solution
In Sheet1 A73, enter:
=INDEX(Sheet2!$A$1:$AF$41,ROW(A1),MATCH($A$1,Sheet2!$A$1:$AF$1,0))
Copy this formula to Sheet1 A74:A105
VBA Solution
Put this code in the Sheet1 module;
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
If Not Intersect(Target, Range("A1")) Is Nothing Then
Application.EnableEvents = False
With Sheet2
Set c = .Rows(1).Find(what:=Sheet1.Range("A1").Value)
If Not c Is Nothing Then
Set c = Intersect(.UsedRange, c.EntireColumn)
Sheet1.Range("A73").Resize(c.Rows.Count, 1).Delete
c.Copy Sheet1.Range("A73")
End If
End With
Application.EnableEvents = True
End If
End Sub
EDITED ANSWER: (according to comment)
We have the following layout of products
Private Sub CommandButton1_Click()
'first we check the user input
Dim u_input As String
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
u_input = LCase(Trim(ws.Range("A1").Value2))
'now we need to determine how many columns there are so we know when to stop looping
Dim lc As Long, lr As Long
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
' loops through all the products
For Each cell In Range(Cells(1, "F"), Cells(1, lc))
' if the product matches the input
If LCase(Trim(cell)) = u_input Then
lr = ws.Cells(ws.Rows.Count, cell.Column).End(xlUp).Row
' copy and paste the active data range to A37
ws.Range(Cells(1, cell.Column), Cells(lr, cell.Column)).Copy
Sheets("Sheet2").Range("A37").PasteSpecial
End If
Next cell
End Sub
So, upon entering cucumber and clicking the button:
We would get the following result:
You can add any number of products there, as long as the first product starts in column F. (though that can also be changed in code).
PS: This will however end up overwriting your data and also cause data to overlap if your data ranges are not the same. It probably would be smarter to paste the data into the next empty row in sheet2 instead of directly to A37
This can be achieved by changing the line
Sheets("Sheet2").Range("A37").PasteSpecial to Sheets("Sheet2").Range(Cells((Rows.Count, "A").End(xlUp).Row, "A")).PasteSpecial
I have values on Sheet 1 and I gave the background color using conditional formatting.
I want to copy only the color and paste it to the corresponding cell of sheet 2 without pasting the value.
Example if sheet 1 cell A1 has red color for specific value, transfer the color to sheet 2 A1.
I use two colors, red and white. Red is for higher value and white is for lower value.
Sub copycolor()
Dim intRow As Integer
Dim rngCopy As Range
Dim rngPaste As Range
For intRow = 1 To 20
Set rngCopy = Sheet1.Range("A" & intRow + 0)
Set rngPaste = Sheet2.Range("b" & intRow)
'Test to see if rows 500+ have a value
If rngCopy.Value <> "" Then
'Since it has a value, copy the value and color
rngPaste.Value = rngCopy.Value
rngPaste.Interior.Color = rngCopy.Interior.Color
End If
Next intRow
End Sub
rngPaste.Interior.Color = rngCopy.DisplayFormat.Interior.Color
Seems to work for me. Keep in mind that DisplayFormat is read-only and is not allowed to return value outside of the function it's used in. Also it is only available in Excel 2010 +
I was editing my answer to include the other stuff you mentioned and realized it was getting confusing to explain it all in separate chunks. Here's a recommended approach to achieve what you're saying.
Public Sub CopyColor()
Dim SourceSht As Worksheet
Dim TargetSht As Worksheet
Dim rngCopy As Range
Dim rngPaste As Range
Dim LastCopyRow As Long
Dim LastCopyColumn As Long
'Define what our source sheet and target sheet are
Set SourceSht = ThisWorkbook.Worksheets("Sheet1")
Set TargetSht = ThisWorkbook.Worksheets("Sheet2")
'Find our used space on the source sheet
LastCopyRow = SourceSht.Cells(Rows.Count, "A").End(xlUp).Row
LastCopyColumn = SourceSht.Cells(1, Columns.Count).End(xlToLeft).Column
'Setup our ranges so we can be sure we don't loop through unused space
Set rngCopy = SourceSht.Range("A1:" & SourceSht.Cells(LastCopyRow, LastCopyColumn).Address)
Set rngPaste = TargetSht.Range("A1:" & TargetSht.Cells(LastCopyRow, LastCopyColumn).Address)
'Loop through each row of each column.
' This will go through each cell in column 1, then move on to column 2
For Col = 1 To LastCopyColumn
For cel = 1 To LastCopyRow
' If the string value of our current cell is not empty.
If rngCopy.Cells(cel, Col).Value <> "" Then
'Copy the source cell displayed color and paste it in the target cell
rngPaste.Cells(cel, Col).Interior.Color = rngCopy.Cells(cel, Col).DisplayFormat.Interior.Color
End If
Next cel
Next Col
End Sub
Simplest would be to apply the same conditional formatting to Sheet2, but use the values from Sheet1 as your criteria. So if Sheet1 Cell A1 has the value that makes it red, add formatting to Sheet2 that turns Sheet2 Cell A1 red as well.
There's a good explanation of how to achieve this here.
.Interior.Color gets the actual colour of the cell rather than the conditionally formatted colour (the one you see). So you can't copy/paste this red colour in your example in this way.
I believe that the only way to get the conditionally formatted colour you see would be to recompute whatever formula you've used in your conditionally formatting criteria.
Excel 2007 conditional formatting - how to get cell color?
Edit
While #JeffK627 was giving an elegant solution, I was knocking up some rough vba code to recompute what I gather your conditional formatting does. I've done this over range A1:A20 on sheet 2. At the moment it colours the cell that contains the value itself, but only requires a little tweak to colour the equivalent cell on another sheet.
Sub ColouringIn()
Dim intColIndex As Integer
Dim dblMax As Double
Dim dblMin As Double
Dim rngCell As Range
'RGB(255, 255, 255) = white
'RGB(255, 0, 0) = red
'so need to extrapolate between
dblMax = Application.WorksheetFunction.Max(Sheet2.Range("A1:A20"))
dblMin = Application.WorksheetFunction.Min(Sheet2.Range("A1:A20"))
For Each rngCell In Sheet2.Range("A1:A20")
If IsNumeric(rngCell.Value) And rngCell.Value <> "" Then
intColIndex = (rngCell.Value - dblMin) / (dblMax - dblMin) * 255
rngCell.Interior.Color = RGB(255, intColIndex, intColIndex)
End If
Next rngCell
End Sub
Adding following example as alternative solution, as I needed something dynamic/active where color IS a required condition of data & not reliant on any other trigger.
Option1:
Dim rngPrev2Update As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cellbox As Range
Dim rngDest As Range
If Not rngPrev2Update Is Nothing Then
For Each cellbox In rngPrev2Update.Cells
Worksheets("Sheet2").Range(cellbox.Address).Interior.ColorIndex = cellbox.Interior.ColorIndex
Next cellbox
End If
Set rngPrev2Update = Target
End Sub
This will update destination cells when cursor is next moved to another cell.
Option2:
Private Sub Worksheet_Activate()
Dim cellbox As Range
Dim rngCells As Range
Set rngCells = Range("B1:B10")
For Each cellbox In rngCells.Cells
Range(cellbox.Address).Interior.ColorIndex = Worksheets("Sheet2").Range(cellbox.Address).Interior.ColorIndex
Next cellbox
End Sub
Will update relevant cells on sheet load.
Note: If you have very large data set you may want to put this into a macro button &/or filter this further for only the cells you need, otherwise this may slow your spreadsheet down.
Appreciating this was some time ago. I would like to do a similar thing however would like to append the Interior Color Reference ie. 255 to the cells value.
so if cell A1 has Hello in the cell and is Colored Red I'd want in the other worksheet cell A1: Hello | 255
Just used | as a delimiter but anything sensible...
I'm working on a long list of data (Column B) that has been formatted using bold and indents. The bold cells contain the titles/category names and the indented cell values are the subcategories.
The row heights are all over the place. It should have been 10.5 for everything, and the bold cells/rows 15. I can change everything to 10.5, but then I need to spend quite a bit of time scrolling through the list amending the bold row heights. I've used the format painter but it's a long list and I didn't want to spend so much time on this part of the process. And now I know that I'll need to do this to another 30 documents.
Does anyone have a quicker way of doing this?
Sub setHeights()
Dim targetRange As Range
Dim targetCell As Range
Set targetRange = Range("B:B")
For Each targetCell In targetRange
If Not IsEmpty(targetCell) Then
If targetCell.Font.Bold Then
targetCell.RowHeight = 15
ElseIf targetCell.Font.Superscript Then
targetCell.RowHeight = 12.75
Else
targetCell.RowHeight = 10.5
End If
End If
Next targetCell
End Sub
You might want to change Range("B:B") to something like Table1.Range("B1:B255")
Rather than setting the range as shown above,
Set targetRange = Range("B:B")
Try setting it like this:
Set TargetRange = Range("B1", Range("B65536").End(xlUp))