Background
I want to write a simple function which swaps the contents of two selected (not necessarily adjacent) cells. I do not want to copy the cell to a temporary cell first. Thus, I really want to swap the cells in place.
Challenge
While simply swaping the content is rather easy by using a Variant temporary variable holding the content of cell 1, overwriting the content of cell 1 with the content of cell 2 and then writing back the content of the variant variable to cell 2, I struggle how to also copy all format related stuff. There are plenty of slots which need consideration (.NumberFormat, .Interior to name just two). Do I really need to copy each of them seperately or is there an easier way to swap the format without using any temporary cell?
Code
Public Sub SwapCells(Optional bolWithFormat As Boolean = True)
'Purpose: switch the content of two cells
On Error GoTo ErrHandler
Dim rngSel As Range
Dim varContent As Variant
Set rngSel = Selection
If (rngSel.Count = 2) Then
With rngSel.Cells(1)
varContent = .Value
.Value = rngSel.Cells(2).Value
rngSel.Cells(2).Value = varContent
End With
Else
'Do nothing, because swap makes only sense for exactly 2 cells
End If
ErrHandler:
Set rngSel = Nothing
End Sub
Per the comments, using a temporary holding cell is much the easiest solution. You can use a cell in your Personal macro workbook to avoid worrying about finding a spare cell in the active workbook. It would probably be wise to set the Saved property of the personal workbook to True afterwards to avoid getting prompted to save that every time you quit Excel after running the macro!
Just for the record, here's the final code (stored in my Personal.xlsb) which I use:
Public Sub SwapCellsGeneral(Optional bolWithFormat As Boolean = False)
'Purpose: switch the content of two cells
'Use Personal.xlsb to use a temporary cell and copy paste
On Error GoTo ErrHandler
Dim rngSel As Range, rngTemp As Range
Dim varContent As Variant
Set rngSel = Selection
Set rngTemp = ThisWorkbook.Sheets(1).Cells(1, 1)
If (rngSel.Count = 2) Then
If (bolWithFormat) Then
rngSel.Cells(1).Copy rngTemp
rngSel.Cells(2).Copy rngSel.Cells(1)
rngTemp.Copy rngSel.Cells(2)
Else
With rngSel.Cells(1)
varContent = .Value
.Value = rngSel.Cells(2).Value
rngSel.Cells(2).Value = varContent
End With
End If
Else
'Do nothing, because swap make only sense for exactly 2 cells
End If
ErrHandler:
'Set this to avoid asking if we want to save personal.xlsb
ThisWorkbook.Saved = True
Set rngSel = Nothing
Set rngTemp = Nothing
End Sub
Related
My main goal is to be able to autofilter merged cells in one column.In the picture below I want row 7-9 to disappear when I remove "6" from the autofilter menu. But as I have figured, I need the value "6" to be held in all the cells "L7:L9" in order for Excel to do so.
The number 6 is calculated by adding "Num1" and "Num2" (2 * 3) by the following function I have placed in "L7":
Function Exposure(arg1 As Range, arg2 As Range) As Variant
Application.EnableEvents = False
Application.Calculation = xlManual
If Application.ThisCell.Offset(, -1).Value <> "-" And Application.ThisCell.Offset(, -2).Value <> "-" Then
Exposure = Left(Application.ThisCell.Offset(, -1).Value, 1) * Left(Application.ThisCell.Offset(, -2).Value, 1)
End If
If Exposure = 0 Then Exposure = "-"
Application.Calculation = xlAutomatic
Application.EnableEvents = True
End Function
I put the following formula inside the merged cell "L7":=Exposure(K7;J7). Then formula is dragged down."Num1" and "Num2" are controlled by valdiation fields, drop-down menu.
My plan was to unmerge after calculating the Exposure Variant, fill the same value in the remaining rows, then re-merge the same area. So I wrote this stand alone Sub:
Sub WorkingSub(rng As Range)
'Set rng = ActiveCell.MergeArea
rng.UnMerge
For i = 2 To rng.Cells.Count
rng.Cells(i).Value = rng.Cells(1).Value 'This line triggers recursion
Next i
rng.Offset(rng.Cells.Count).Copy 'Copies format from below
rng.PasteSpecial Paste:=xlPasteFormats 'Paste that keeps the values even after merging
End Sub
Which works on its own, but not when called inside the function above. After setting the first value, the function triggers "something", debug show the the function starting over, skipping the rng.PasteSpecial Paste:=xlPasteFormats code.
So my question to you guys is how do i write my function(s) to stop "recursing" and let me unmerge during the function call?
Or am I attacking this the wrong way? What would you do?
I am stuck with merged cells for lots of reasons, this is just one part of many inside this spreadsheet.
An interesting problem. You can capture the filter event through trapping a change in a calculation and then processing the rows of the table for visibility. I've made some assumptions for the initial table range assignment which may need some alteration.
The If Not VisRange Is Nothing Then is actually redundant as the prior line will throw a fit if an empty range is assigned, but I just kept it in. In order to get around having a null range, keep the header range in the initial MergedTableRange so there will always be a row visible
Within a cell either somewhere in the same worksheet or a 'dummy' worksheet
=SUBTOTAL(103,Sheet1!A3:H10) 'Or other table range
In the worksheet module code
Private Sub Worksheet_Calculate()
Dim ws As Worksheet: Set ws = Worksheets("Sheet1")
Dim MergedTableRange As Range: Set MergedTableRange = ws.Range("A2").CurrentRegion
Dim Cell As Range
Dim VisRange As Range: Set VisRange = MergedTableRange.SpecialCells(xlCellTypeVisible)
If Not VisRange Is Nothing Then
For Each Cell In VisRange
If Not Application.Intersect(Cell.MergeArea, VisRange).Address = Cell.MergeArea.Address Then
Cell.Rows.Hidden = True
End If
Next Cell
End If
End Sub
I came up with a different approach. Maybe there's a downside I'm missing. But my few test runs have succeeded.
I allready have a hidden sheet named "Template" where the formats for each new "#" is stored. So whenever the user wants to insert a new row, the template have the merged and the non-merged cells ready and insert is done through copy paste.
In that same sheet I made 2 merged rows in column 2, 3 merged cells in column 3 and so on:
This way I'm able to copy the correct number of merged rows to paste after filling the unmerged rows with their correct values.
I came to the conclusion that I could catch a Worksheet_change on the "Num1" and "Num2" columns instead of catching and canceling an autofilter call.
So I added:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Target.Worksheet.Range("J:J")) Is Nothing Then
Call UnMergeMerge(Cells(Target.Row, "L").MergeArea)
End If
If Not Intersect(Target, Target.Worksheet.Range("K:K")) Is Nothing Then
Call UnMergeMerge(Cells(Target.Row, "L").MergeArea)
End If
End Sub
And the UnMergeMerge sub ended up being:
Sub UnMergeMerge(rng As Range)
Application.EnableEvents = False
Application.ScreenUpdating = False
rng.UnMerge
For i = 2 To rng.Cells.Count
rng.Cells(i).Value = rng.Cells(1).Value
Next i
With Sheets("Template")
.Range(.Cells(8, rng.Cells.Count), .Cells(8 + rng.Cells.Count, rng.Cells.Count)).Copy
End With
rng.PasteSpecial Paste:=xlPasteFormats
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Still not sure it's the fastest and best approach...Do you guys still believe catching, undoing and running a different autofilter would be more effective?
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
I am trying to produce a VBA function that will hide all columns for which cells D9:CC9 are not equal to "A6" and cells D8:CC8 are not equal to "12." Based on the script below, the system keeps returning an error. I am new to VBA, was hoping someone might be able to assist.
Thanks!
Dim MyCell As Range
Set MyCell = Range("D9:CC9,D8:CC8")
For Each cell In MyCell
If cell.Value <> WorksheetFunction.Index(Range("D9:CC9"),WorksheetFunction.Match(Range("A6")&"12",Range("D9:CC9")&Range("D8:CC8"), 0))
cell.EntireColumn.Hidden = True
End If
Next cell
Most operations are performed quite different using VBA than doing them manually. If you want to work with VBA then should do some research about working with variables and objects. This pages should be of interest.
Variables & Constants, Excel Objects, With Statement & Range Properties (Excel)
I have done some changes to your code, see comments within, and refer to the pages mentioned above.
Sub Rng_HideColumns()
Dim rTrg As Range, rCol As Range
Dim sCllVal As String
Rem Set rTrg = ThisWorkbook.Sheets("Sht(0)").Range("D9:CC9,D8:CC8")
Rem Refers to the worksheet you want to work with instead or using the active worksheet
With ThisWorkbook.Sheets("Sht(0)")
Rem Get value to match
sCllVal = .Range("A6").Value2 & 12
Rem Set Range to Search
Set rTrg = .Range("D8:CC9")
For Each rCol In rTrg.Columns
With rCol
If .Cells(2).Value2 & .Cells(1).Value2 = sCllVal Then
.EntireColumn.Hidden = 1
Else
.EntireColumn.Hidden = 0
End If: End With: Next: End With
End Sub
I receive an excel file monthly and have to export parts of it to a new file. I have a list of identifier numbers and I am trying to match the list of numbers in the selected list to the full file and then export the rows of relevant data to a new sheet.
Sub Run_All_Macros()
Application.ScreenUpdating = False
Sheets.Add.Name = "Output"
Call Convert_to_Numbers
Call Highlight_Selected_Contractors
End Sub
'Original Spreadsheet is formatted incorrectly
'Convert PSD Codes to Numbers
Sub Convert_to_Numbers()
Dim xCell As Range
Range("A2:A2500").Select
For Each xCell In Selection
xCell.Value = CDec(xCell.Value)
Next xCell
End Sub
'Highlight Selected Contractors
Sub Highlight_Selected_Contractors()
Dim Full, Selection, Code, SelectedCode As Range
Worksheets("Sheet1").Select
'Set all cells in Column A Sheet 1 to Full
Set Full = Worksheets("Sheet1").Range("A1", Range("A1").End(xlDown))
'Set all cells in Column A Sheet 2 to Selection
Worksheets("Sheet2").Select
Set Selection = Worksheets("Sheet2").Range("A1", Range("A1").End(xlDown))
'If the numbers match highlight the cell
For Each Code In Full
For Each SelectedCode In Selection
If Code.Value = SelectedCode.Value Then
*** Code.Select
Selection.Copy
Sheets.Select ("Output")
ActiveSheet.Paste
End If
Next SelectedCode
Next Code
End Sub
After executing this code column A in 'Output' is filled with zeros from A2:A2500. From messing around with breakpoints I've identified the problem to be where I've placed * but I'm not sure what's wrong with what's written there.
Thanks
There few errors in the code above and I also have few suggestions and finally the code.
ERRORS
1) Sheets.Add.Name = "Output" This line will give you an error if there is already a sheet called "Ouput". Delete the sheet first and then create it. You must be wondering that in case the sheet is not there, then how can I delete it? For such scenarios you can use On Error Resume Next which should be avoided in most cases.
2) When working with ranges, always specify which sheet you are referring to else Excel will always assume that you are referring to the "ActiveSheet". As you realized that Sub Convert_to_Numbers() was taking Output Sheet into consideration whereas you want the operation to happen in "Output" Sheet.
3) Dim Full, Selection, Code, SelectedCode As Range As mentioned in my comments earlier avoid using Excel Reserved words as variables. Also unlike VB.Net, if you declare variables as you did in VBA then only the last variable will be declared as Range. The other 3 will be declared as variant. VB defaults the variable to being type Variant. A Variant type variable can hold any kind of data from strings, to integers, to long integers, to dates, to currency etc. By default “Variants” are the “slowest” type of variables. Variants should also be avoided as they are responsible for causing possible “Type Mismatch Errors”. It’s not that we should never use Variants. They should only be used if you are unsure what they might hold on code execution.
4) Avoid the use of words like .ActiveCell, Selection, Select, Activate etc. They are a major cause of errors. Also they slow your code down.
SUGGESTIONS
1) Instead to using Sheets("WhatEver") every time, store it in a variable and then use that variable. Will cut down your code.
2) Indent your code :) it's much easier to read
3) Group tasks together. For example if you have to do with something with a particular sheet then keep it together. It is easier to read and amend if required.
4) Instead of hard coding your values, get actual ranges. Range("A2:A2500") is a classic example. Will you always have data till 2500? What if it is less or more?
5) End(xlDown) will never give you the last row if there is a blank cell in between. To get the last row in a column, say A in "Sheet1", use this
Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row`
6) Instead of looping, you can use the WorksheetFunction CountIf(). Loops should be avoided as much as possible as they slow down your code.
7) Use appropriate Error handling.
8) Comment your code. It's much easier to know what a particular code or section is doing.
CODE
Option Explicit
Sub Run_All_Macros()
Dim ws1I As Worksheet, ws2I As Worksheet, wsO As Worksheet
Dim ws1LRow As Long, ws2LRow As Long, wsOLr As Long
Dim xCell As Range, rFull As Range, rSelection As Range
Dim rCode As Range, rSelectedCode As Range
On Error GoTo Whoa '<~~ Error Handling
Application.ScreenUpdating = False
'~~> Creating the Output Sheet
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Output").Delete
On Error GoTo 0
Sheets.Add.Name = "Output"
Application.DisplayAlerts = True
'~~> Working with 1st Input Sheet
Set ws1I = Sheets("Sheet1")
With ws1I
'~~> Get Last Row of Col A
ws1LRow = .Range("A" & Rows.Count).End(xlUp).Row
'~~> Set the range we want to work with
Set rFull = .Range("A1:A" & ws1LRow)
'~~> The following is not required unless you want to just format the sheet
'~~> This will have no impact on the comparision. If you want you can
'~~> uncomment it
'For Each xCell In .Range("A2:A" & ws1LRow)
'xCell.Value = CDec(xCell.Value)
'Next xCell
End With
'~~> Working with 2nd Input Sheet
Set ws2I = Sheets("Sheet2") '<~~ Input Sheet 2
ws2LRow = ws2I.Range("A" & Rows.Count).End(xlUp).Row
Set rSelection = ws2I.Range("A1:A" & ws2LRow)
'~~> Working with Output Sheet
Set wsO = Sheets("Output")
wsO.Range("A1") = "Common values"
wsOLr = wsO.Range("A" & Rows.Count).End(xlUp).Row + 1
'~~> Comparison : If the numbers match copy them to Output Sheet
For Each rCode In rFull
If Application.WorksheetFunction.CountIf(rSelection, rCode.Value) > 0 Then
rCode.Copy wsO.Range("A" & wsOLr)
wsOLr = wsOLr + 1
End If
Next rCode
MsgBox "Done"
LetsContinue:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
Let me know if you still get any errors :)
HTH
I have 2 excel files with a lot of data in each. The data is structured exactly the same in both files but the values might have changed as the data is from two different times.
Basically I want to find some way to automatically compare values in each cell for the two files and highlight the cells that have changed values in file #2.
Kindly share your ideas!
Example:
File 1 :
a / 1 / 2
File 2 :
a / 1 / 8
(/ - indicates new cell)
This may not be the most efficient way (can handle 25k cells in a few seconds, though), but it more than makes up for it in simplicity.
This will look at every cell in Sheet2 and compare it against the value in the cell at the same address in Sheet1 of the file you specify. If it's different, the cell in Sheet2 is highlighted yellow.
Sub FindDifferences()
Application.ScreenUpdating = False
Dim cell As Range
Dim wkb1 As Workbook
Dim wks1 As Worksheet
Set wkb1 = Workbooks.Open(Filename:="C:\MyBook.xls")
Set wks1 = wkb1.Worksheets("Sheet1")
For Each cell In ThisWorkbook.Sheets("Sheet2").UsedRange
If cell.Value <> wks1.Cells(cell.Row, cell.Column).Value Then
cell.Interior.Color = vbYellow
End If
Next
wkb1.Close
Application.ScreenUpdating = True
End Sub
Note:
You could easily tailor this to compare 2 sheets in the same file by simple removing the wkb1 and wks1 variables and changing wks1.Cells... to Sheets("Sheet1").Cells...
You can use this online website - xlcomparator.net (click on the flag on the top right for an english version).
Or try this software: http://www.formulasoft.com/excel-compare.html
Or try this kind of macro (that check the first column) and adapt it to your needs:
sub compare()
Application.ScreenUpdating = False
Dim coll1 As New Collection, coll2 As New Collection
Dim cell1 As Range, cell2 As Range
Dim Element1 As Object, Element2 As Object
Workbooks("workbook1.xls").Activate
For Each Cellule1 In Range("a:a")
coll1.Add cell1
Next Cellule1
Workbooks("workbook2.xls").Activate
For Each cell2 In Range("a:a")
coll2.Add cell2
Next cell2
For Each Element1 In coll1
For Each Element2 In coll2
If Element1 <> Element2 Then
Element1.Font.Color = vbRed
Else
Element1.Font.Color = vbBlack
Exit For
End If
Next Element2
Next Element1
Application.ScreenUpdating = True
end sub
Source - excelabo, a french website
Two further options:
Spreadsheet Advantage, http://www.spreadsheetadvantage.com/, where you can get a free 30 day trial
This is my favourite tool as it also offers a row and column alignment option to ensure both sheets are presented indentically by row and column, before running the compare outputs code to highlight any differences
Myrna Lawson's compare.xla addin (free) available at Chip Pearson's site http://www.cpearson.com/Zips/Compare.zip