How to loop VBA code for different columns/sheets - excel

Let me preface this with that I am by no means a developer/code writer, so I am running on the barest of bones when it comes to understanding everything.
In an excel sheet I am creating for work, I am using code that checks cells for their color based on conditional formatting, then changes the color of the cells in another sheet to match them. I went with a macro vs CF due to the number of columns/rows that are being controlled, and to let each person using the sheet customize the color to what they prefer without having to change hundreds of lines to do it.
The code I am using is :
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim xWRg, xDERg, xlWRg, xlDERg As Range
Dim xfnum As Long
'On Error Resume Next
Set xDERg = Sheets("Data Entry").Range("D9:D200")
Set xWRg = Sheets("Worksheet").Range("E6:E200")
For xfnum = 1 To xWRg.Count
Set xlWRg = xWRg.Cells.Item(xfnum)
Set xlDERg = xDERg.Cells.Item(xfnum)
xlDERg.Interior.Color = xlWRg.DisplayFormat.Interior.Color
Next xfnum
End Sub
I have it working for that specific range, but I also need it to check G9:G200 on Data Entry and K6:K200 on the worksheet, a long with a couple other columns. There are 7 total ranges that need to be controlled by this.

Here is your code rewritten to clean it up. Note: If your destination range is smaller then the source range, then cells below the destination range may be colored.
Dim xWRg As Range: Set xWRg = Sheets("Worksheet").Range("E6:E200") 'Set your source range
Dim xDERg As Range: Set xDERg = Sheets("Data Entry").Range("D9:D203") 'Set your destination range, usaually same number of cells
For xfnum = 1 To xWRg.Count 'loop through the number of items in source range
'copy the conditional formating color to the destination range
xDERg.Item(xfnum).Interior.Color = xWRg.Item(xfnum).DisplayFormat.Interior.Color
Next xfnum 'loop
If you could clarify what sheet/range will activate the Worksheet_SelectionChange event, and the additional five ranges you need to add, I can provide better guidance, it depends on the layout of the ranges you want to work with.

Related

VBA Remove format from empty cells in Excel (while ignoring the merged cells)

I came across this link in the forum
VBA Remove format from empty cells in Excel
However, I would like to clear the formatting of empty cells, ignoring the merged cells.
This should do the trick. You will need to make two updates here:
Update the sheet name in code to the sheet of interest
Update the range in code to the relevant range you want this code to work on (for testing purposes, the range is currently set to ws.Range("A1:A30"))
The macro will loop trough each cell in the provided range (which you need to update per #2) and will check to see if the cell is both empty AND unmerged. If the cell meets this criteria, we will add it to a range variable (Format_Range) and continue the loop. Once the loop is complete, clear the formatting of the variable range all at once.
Sub Custom_Format()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") 'Update Sheet Name
Dim Target As Range, Format_Range As Range
For Each Target In ws.Range("A1:A30") 'Update Range to run macro on
If Target.MergeCells = False And Target = "" Then
If Not Format_Range Is Nothing Then
Set Format_Range = Union(Target, Format_Range)
Else
Set Format_Range = Target
End If
End If
Next Target
'Make sure the range is not empty before removing format
If Not Format_Range is Nothing Then Format_Range.ClearFormats
End Sub
Sample Output
Here is a before (Column A) and after (Column B) photo when using the macro. Note that all unmerged cells had the formatting stripped from them when they were blank while merged cells kept their formatting regardless.
you could use SpecialCells property of Range object and get all blank cells on which testing if they are part of a merged area:
Dim cel As Range
With ActiveSheet ' <- change this to your actual sheet reference of interest
With .UsedRange ' <- change this to your actual range reference of interest
For Each cel In .SpecialCells(XlCellType.xlCellTypeBlanks).Cells
If Not cel.MergeCells Then Debug.Print cel.ClearFormats
Next
End With
End With

Copy non-contiguous cells and paste in a row retaining number format Excel VBA

I hope someone can help me with this as it's driving me up the wall!
There are 5 non-contiguous cells in a worksheet that I want to copy to the next empty row on another worksheet whilst retaining the number formatting (which varies). I have this so far but am struggling working out how to retain formatting. Can anyone please help? Thanks I anticipation.
`With wsCalc
For bRun = 1 To 4
bData(bRun) = Application.Choose(bRun, .Range("g2"), .Range("b2"), .Range("R2"), .Range("Q14"))
Next bRun
End With
wSResults.Cells(Rows.Count, "a").End(xlUp).Offset(1).Resize(, 4).Value = bData
`
Here's a possible solution, using your hard-coded cell addresses. You will have to set wsCalc and wsResults to their proper worksheets. Slightly more elegant would be to define a "non-contiguous" range on your wsCalc sheet (select the 1st cell, keep Ctrl pressed and select the next one etc, then type a name in the drop-down box just to the left of the formula bar).
Option Explicit
Sub CopyWithFormat()
Dim wsCalc As Worksheet
Set wsCalc = ActiveSheet 'Or whatever your calc sheet is
Dim rngSource As Range
Set rngSource = wsCalc.[G2,B2,R2,Q14]
Dim wsResults As Worksheet
Set wsResults = ActiveSheet 'Or whatever your result sheet is
Dim clDest As Range
Set clDest = wsResults.Cells(Rows.Count, "a").End(xlUp).Offset(1)
Dim cl As Range
For Each cl In rngSource.Cells
clDest.Value = cl.Value
clDest.NumberFormat = cl.NumberFormat
Set clDest = clDest.Offset(1)
Next cl
End Sub
Instead of using .Value, try .Text. It retains formatting. See below.
Gary's Student is right, text is read only, it should be used for the input not the output.
bData(bRun) = Application.Choose(bRun, .Range("g2").Text, .Range("b2").Text, .Range("R2").Text, .Range("Q14").Text)
I also agree with other answer the entire code could be set up more straight forward.

Copy-Paste non-contiguous ranges

I have data in Excel. I want to copy the header and some data from the middle of sheet to Powerpoint. I know that you can't copy a selection of non-adjacent cells in Excel, but I was under the impression it would work with VBA.
My try:
With Workbooks(1).Sheets(1)
Set rng = Union(.Range("B2:K3"), .Range("B45:K85"))
End With
I can select "rng", but I can't paste it anywhere because I get the error message that you can't paste non-adjacent cells.
I've also tried this, but it resulted in the whole table (B2:K85) getting copied:
With ThisWorkbook.Sheets("Sheet1")
Set rng1 = .Range("B2:K3")
Set rng2 = .Range("B45:K85")
Set NewRng = .Range(rng1.Address & ":" & rng2.Address)
End With
I've googled this question and tried various things, but either I misunderstood what is possible with VBA or I'm making a mistake (over and over again).
So do I have to alter my code or do I have to work around it? My alternative solution would be to copy-paste each of the two ranges, put them underneath each other and then copy the whole, now contiguous range.
You can use the Areas property of the Range object to get the unionized ranges. Code like the below will loop through each of the sub-ranges, copy them, and paste them elsewhere. Try and adapt to your needs, and write back if you need some help.
Sub Test()
Dim rng As Range
Dim r As Range
Dim destination As Range
Set rng = Union(Range("A1:B3"), Range("D1:E2"))
Set destination = Range("H1")
For Each r In rng.Areas
r.Copy destination
Set destination = destination.Offset(, 3)
Next r
End Sub

Excel List of Blank Cells

So I have a big excel sheet with a bunch of empty cells in various locations. I want an easy to work with list of which cells are empty. I was hoping to make a new worksheet that was populated with the locations of the empty cells. I wanted to have this to just populate the cells I want it to. I kept the header from the worksheet I will be checking and added a blank cells count, so I want the following cells in the column to be populated by the list of empty cell locations.
Now I know I can use =ISBLANK to test if a cell is empty or not, but I only care about the cells that return TRUE. So I figure I'll need a loop. And I want the location of the cell so I can use =CELL. And to make this most readable I want to do this on a column by column basis.
But I want to populate a spreadsheet with this information in a manner similar to how functions work (I just want to copy and paste it to other cells and columns). But it's pretty clear that I am going to need VBA.
My question is how can I create a macro to populate my spreadsheet with a list of empty cells? How do I apply it to the cells?
I assume you have data in sheet1, I have used sample range// Range("A1:c15") however you can define range as per need and blank cells address will be published in next sheet.
Sub FindBlank()
Dim rng As Range
dim i as long
For Each rng In Sheet1.Range("A1:c15").SpecialCells(xlCellTypeBlanks)
i = i + 1
Sheet2.Cells(i, 1) = rng.Address
Next
End Sub
If you want a list of the cells that are empty, you can use Range().SpecialCells(xlCellTypeBlank):
Sub getEmptyCellAddresses()
Dim rng As Range
Dim ws as Worksheet
Set ws = Sheets("Sheet1") ' CHANGE AS NECESSARY
Set rng = ws.Range("A1:A15").SpecialCells(xlCellTypeBlanks) ' Edit/change range as necessary
ws.Cells(1, 2).Value = rng.Cells.Address ' Change `ws.cells(1, 2)` to whatever destination you like
End Sub
Edit: Ah, beaten by 16 seconds by #RamAnuragi ...but anyways, they're slightly different ways to tackle the question so I'll leave it.
Edit: For funsies, here's another way to put them all in a column, one row per cell...and more, per your comments.
Sub listEmptyCells()
Dim emptyAddresses() As String
Dim i As Long
Dim ws As Worksheet
Dim rng As Range
Set ws = Sheets("Sheet1") ' CHANGE AS NECESSARY
Set rng = ws.Range("A1:A15")
If WorksheetFunction.CountBlank(rng) = 0 Then
MsgBox ("No empty cells in the range")
Exit Sub
End If
emptyAddresses() = Split(rng.SpecialCells(xlCellTypeBlanks).Address, ",")
For i = LBound(emptyAddresses) To UBound(emptyAddresses)
ws.Cells(i + 1, 2).Value = emptyAddresses(i)
Next i
End Sub

How to selecting a range with data on excel with vba

How can i modify the code below to select data from any worksheets and copy they to another worksheet for example select and copy data from Worksheets("uno") and paste they to Worksheets("duo"). Because the code below selects data only on activesheet
Set tbl = ActiveCell.CurrentRegion
tbl.Resize(tbl.Rows.Count, tbl.Columns.Count).Select
I have a code to copy data from any sheet to another for example
Worksheets("uno").Range("A5:T5,A7:T56,W5,Y5,W7:W56,Y7:Y56").Copy _
Worksheets("duo").Range("B4")
But i want to copy a range with data and ignore blank cells because the range A5:T5 it doesn't have always all cells with data concretely the last cells of this range, two or three of those, and also the same on range A7:T56.
My problem is how to select a range with data and ignore the blank cells inside the range A7:T56 concretely the last rows and the last columns which haves blank cells
Well, for the first part, where "the code selects data only on the activesheet", you just need to activate the correct sheet (for example: "Worksheets("uno").Activate") before executing "Set tbl = ActiveCell.CurrentRegion".
I am not really sure if I understand you correctly, but these are my thoughts:
If you don't want to activate worksheet "uno" you need to create a reference to that worksheet to have a direct access to it:
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Set wkb = Excel.Application.Workbooks("<name of your workbook>")
Set wks = wkb.Worksheets("uno")
If you now use the following code:
wks.Range("<your range>").Copy
you have just copied your selected cells, now you can paste it wherever you want.
As for the part with avoiding empty cells:
Generally speaking, you need to create a method of checking whether relevant cells are empty or not before you add them to your range.
Personally, I would avoid trying to copy the whole range as such. Instead I would:
1) loop through all relevant cells in your range one by one
2) for each cell check if it's empty
3) if empty, go to next cell
4) if not empty, copy that cell and paste to the target worksheet
5) jump to next relevant cell
6) when you reach the cell which is just after your last cell, quit looping
I would use the above defined wks object.
Note that a Range object can be treated as a collection of strings, so you can iterate using For... Next loop (For Each loop does not guarantee the index order).
Something like this should do:
Dim rng As Range
Set rng = wks.Range("<your range>")
Dim numOfItems As Integer, itm, i As Integer
numOfItems = rng.Count
For i = 1 To numOfItems
itm = rng.item(i)
If itm <> "" Then
'set value of the corresponding cell in your target worksheet to itm
'<relevant cell>.Value = itm
Else
'do nothing
End If
Next i
I hope it's at least a little bit helpful.

Resources