I'm looking for a vba code snippet to get me started.
I have a column in one of my worksheets that has values (non-unique). From this column I need to either
Replace all found cells in the entire workbook that have the same value with the format found in the original cell or
If the cell has no background color to assign it a new unique color background (unique is based on previous cells in the column) and find and replace all cells in the entire workbook with this format.
I don't believe I can use conditional formatting for I have too many cells that would meet the criteria and it would slow excel down to an unacceptable speed.
Alright so based on the prior comments here is what I have so far.
Sub FormatFill()
Dim sRng As Range
Dim cCell As Range
Dim nCell As Range
Dim bClr, lVal
Application.ScreenUpdating = False
Range("B1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Set sRng = Selection
'Fill all legend formats
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
For Each cell In Selection
lVal = cell.Value
bClr = cell.Interior.Color
Set cCell = sRng.Find(What:=lVal, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not cCell Is Nothing Then
Set nCell = cCell
Do
cCell.Interior.Color = bClr
Set cCell = sRng.FindNext(After:=cCell)
If Not cCell Is Nothing Then
If cCell.Address = nCell.Address Then Exit Do
Else
Exit Do
End If
Loop
End If
Next
Application.ScreenUpdating = True
End Sub
I am still working out how to capture and assign the unique colors for the other values on the rest of the workbook.
Related
I am very new to VBA and I was wondering how to copy only the white cells of a worksheet and paste them to the same places but to another workbook.
Specifically, I have two workbooks with multiple sheets and they are the same, but the source workbook has some white cells filled and the destination workbook has these cells empty. I want to transfer the values from the source white cells to the destination white cells.
Also if it is possible, I want to fill the empty white cells with "0".
I have found some pieces of code to copy all coloured cells to another excel worksheet but they do not transfer to another workbook and the exact places.
Sub CopyHighlightedTransactions()
Dim TransIDField As Range
Dim TransIDCell As Range
Dim ATransWS As Worksheet
Dim HTransWS As Worksheet
Set ATransWS = Worksheets("All Transactions")
Set TransIDField = ATransWS.Range("A2", ATransWS.Range("A2").End(xlDown))
Set HTransWS = Worksheets("Highlighted Transactions")
For Each TransIDCell In TransIDField
If TransIDCell.Interior.Color = RGB(255, 0, 0) Then
TransIDCell.Resize(1, 10).Copy Destination:= _
HTransWS.Range("A1").Offset(HTransWS.Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
End If
Next TransIDCell
HTransWS.Columns.AutoFit
End Sub
Thank you in advance.
If the animation above is something that you mean (if I understand you correctly), maybe you want to try the sub below :
Sub test()
Dim wbS As Worksheet: Dim wbT As Worksheet
Dim rgData As Range: Dim c As Range
Application.ScreenUpdating = False
'prepare variable for the workbook and sheet of the source and target
Set wbS = Workbooks("Source.xlsm").Sheets("Sheet1") 'change as needed
Set wbT = Workbooks("Target.xlsx").Sheets("Sheet1") 'change as needed
'the range of the data to be searched
Set rgData = wbS.Range("A1:D10") 'change as needed
'prepare the color to be searched
With Application.FindFormat
.Clear
.Interior.Color = vbWhite
End With
'start searching as c variable
Set c = rgData.Find(What:=vbNullString, SearchFormat:=True)
'loop until all cells in rgData is checked if the color is white or not
'if found white then copy the c, paste to wbT with that c address
If Not c Is Nothing Then
FirstAddress = c.Address
Do
c.Copy Destination:=wbT.Range(c.Address)
Set c = rgData.Find(What:=vbNullString, after:=c, SearchFormat:=True)
Loop While c.Address <> FirstAddress
End If
End Sub
To test the code, make a copy of your workbook (both the source and the target). Copy the sub, paste on the copied workbook then run it. Both workbooks must be opened. It will take time if your data range is big as the code will check all the cell which has white color within the rgData.
the source workbook has some white cells filled
Please remember, the code is looking for the cell which is filled with white color.
I'm curious if the test2 sub below is faster because there's no loop.
Sub test2()
Dim rgW_orig As Range: Dim rgDest As Range
Dim rgW As Range: Dim rgX As Range
Dim rgBlank As range
Application.ScreenUpdating = False
Set rgW_orig = Sheets(1).Range("A1:D10")
Set rgDest = Workbooks("Target.xlsx").Sheets(1).Range(rgW_orig.Address)
With Application.FindFormat.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Workbooks.Add
Set rgW = ActiveSheet.Range(rgW_orig.Address)
rgW_orig.Copy Destination:=rgW
With rgW
.Replace What:="", Replacement:=True, LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=True, ReplaceFormat:=False
Set rgX = .SpecialCells(xlConstants, xlLogical)
End With
rgW.Value = "": rgX.Value = 1
set rgBlank = rgW.SpecialCells(xlBlanks)
rgW.Value = rgW_orig.Value
rgBlank.ClearContents
rgW.Copy
rgDest.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
True, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Close False
End Sub
The test2 macro use a new workbook as a helper, and assumes that the range of data in the Source.xlsm (where the macro reside) is the same within the range of data in the Target.xlsx.
First, it set a range the same address with rgW_orig in the new workbook as rgW variable. Then it copy the rgW_orig and paste it to rgW
Then within the new workbook (the helper workbook) :
it get all cells which filled with white color (by replacing the cell with white color with TRUE boolean), set it as rgX variable.
Next, it fill the whole range (the rgW) with blank, and fill the rgX with 1, then get all cells which has no value (blank) as rgBlank variable.
It copy again the rgW_orig into rgW, then clear the content of rgBlank. Now in this helper workbook within the rgW, the cells with value are only the one with white color, the rest are blank.
Finally it copy the rgW, paste "skip blank" into rgDest then close the helper workbook without saving.
Still not so sure though if this test2 sub is faster than the sub before.
I'm writing a Sub that finds all instances of the word "uM" in a single cell and change the font to blue. Here's a picture of what I want the code to do, and what my code outputs.
Here's my code:
Sub Highlight_uM()
Dim WS As Worksheet
Dim Attention As Range
Dim Cell As Range
Dim Counter As Integer
Set WS = ActiveWorkbook.ActiveSheet
Set Attention = WS.Cells.Find(What:="Attention", LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'Find Attention range
For Each Cell In Attention
For Counter = 1 To Len(Cell)
If Cell.Characters(Counter, 1).Text = "u" Then
Cell.Characters(Counter, 1).Font.ColorIndex = 42
End If
Next
Next Cell
End Sub
As you can see from my code, it only selects .Text = "u". If I change it to = "uM", the sub doesn't do anything. Any tips on how to amend my code to highlight every instance of the entire word "uM" in the cell?
You can use this code:
Sub highlightCellCharacters()
Range("C1").Select
Dim rng As Range
Set rng = Range("C1:C6")
For Each Cell In rng
Dim Counter As Integer
For Counter = 1 To Len(Cell)
If Cell.Characters(Counter, 2).Text = "uM" Then
Cell.Characters(Counter, 2).Font.ColorIndex = 3
End If
Next
ActiveCell.Offset(1, 0).Select
Next Cell
End Sub
This will work for cells C1 to C6
I have a spreadsheet that is generated as a report in our Enterprise system and downloaded into an Excel spreadsheet. Blank cells in the resulting spreadsheet are not really blank, even though no data is present - and the blank cells do Not contain a 'space' character.
For example, the following cell formula in A2 returns TRUE (if A1 is a blank cell):
=IF(A1="","TRUE","FALSE")
However,
=ISBLANK(A1)
returns FALSE.
You can replicate this problem by typing an apostrophe (') in a cell and copying the cell. Then, use Paste Special...Values to paste to another cell and the apostrophe is not visible in the pasted cell, nor in the Formula Bar. There appears to be a clear cell, but it will evaluate to FALSE using ISBLANK.
This causes sorting to result in the fake blank cells at the top of an ascending sort, when they need to be at the bottom of the sort.
I can use a vba loop to fix the fake blanks, to loop through every column and evaluate
IF Cell.VALUE = "" Then
Cell.Clear
but because the spreadsheet has tens of thousands of rows of data and as many as 50 columns, this adds substantial overhead to the program and I would prefer to use FIND and Replace.
Here is the code that does not currently work:
Range("ZZ1").Copy
Range("Table1[#All]").Select
With Selection
.Replace What:="", Replacement:=.PasteSpecial(xlPasteValues, xlNone, False, False), _
LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End With
The following things do not work to clear the fake blank cells either:
Replacement:= vbnullstring
Replacement:= ""
Replacement:= Cells.Clear
Replacement:= Cells.ClearContents
Replacement:= Cells.Value = ""
I have tried 20 other things that do not work either.
Try this
With ActiveSheet.UsedRange
.NumberFormat = "General"
.Value = .Value
End With
A variant array provides an efficient way of handling the false empties:
Sub CullEm()
Dim lngRow As Long
Dim lngCol As Long
Dim X
X = ActiveSheet.UsedRange.Value2
For lngRow = 1 To UBound(X, 1)
For lngCol = 1 To UBound(X, 2)
If Len(X(lngRow, lngCol)) = 0 Then X(lngRow, lngCol) = vbNullString
Next
Next
ActiveSheet.UsedRange.Value2 = X
End Sub
The problem is that you are searching for a hidden .PrefixCharacter which are not covered by the standard replacement function. For more information on this you might want to visit MSDN: https://msdn.microsoft.com/en-us/library/office/ff194949.aspx
In order to find and replace these you'll have to use the .Find function because it can look at the formulas (rather than only at a cell's value). Here is a short sample code to illustrate that:
Option Explicit
Public Sub tmpTest()
Dim cell As Range
Dim rngTest As Range
Dim strFirstAddress As String
Set rngTest = ThisWorkbook.Worksheets(1).Range("A1:G7")
Set cell = rngTest.Find("", LookIn:=xlFormulas, lookat:=xlPart)
If Not cell Is Nothing Then
strFirstAddress = cell.Address
Do
cell.Value = vbNullString
Set cell = rngTest.FindNext(cell)
Loop While strFirstAddress <> cell.Address And Not cell Is Nothing
End If
End Sub
I can't figure out anything that you could put in Replacement to get that to work. I'm afraid you're stuck looping. You can reduce the overhead by using .Find instead of looping through every cell.
Sub ClearBlanks()
Dim rng As Range
Dim rFound As Range
Dim sFirstAdd As String
Dim rFoundAll As Range
Set rng = Sheet1.UsedRange
Set rFound = rng.Find(vbNullString, , xlValues, xlWhole)
If Not rFound Is Nothing Then
sFirstAdd = rFound.Address
Do
If rFoundAll Is Nothing Then
Set rFoundAll = rFound
Else
Set rFoundAll = Application.Union(rFound, rFoundAll)
End If
Set rFound = rng.FindNext(rFound)
Loop Until rFound.Address = sFirstAdd
End If
If Not rFoundAll Is Nothing Then
rFoundAll.ClearContents
End If
End Sub
You can use the table filter to select the (seemingly) blank cells in each column and clear the contents. This should be quicker than finding each blank cell.
Sub clearBlankTableEntries()
Dim tbl As ListObject, c As Byte
Set tbl = ActiveSheet.ListObjects("testTable")
For c = 1 To tbl.Range.Columns.Count
tbl.Range.AutoFilter Field:=c, Criteria1:="="
Range(tbl.Name & "[Column" & c & "]").ClearContents
tbl.Range.AutoFilter Field:=c
Next c
End Sub
I am having problems with a macro which should search for each mycell of myrange in turn and copy it to another sheet if it is found in the GL sheet. However it continues to run after the cells in myrange (i.e. it continues to run on all the blank rows under myrange). myrange is just 10 rows of data. Here is the code:
Dim myrange As Range
Dim mycell As Range
Set wbProjects = Workbooks("Expense Project Jobs.xlsx")
Set wbGL = Workbooks("GL.xml")
Set wbProjectJournal = Workbooks("Expense Project Journal.xlsx")
wbProjects.Activate
LastrowJob1 = Sheets("Project_Costs").Range("F" & Rows.Count).End(xlUp).Row
Set myrange = Range("F2:F" & LastrowJob1)
'LOOP START
For Each mycell In myrange
If mycell = "" Then
GoTo ErrorHandlerMyCell
End If
mycell.Copy
wbGL.Activate
On Error GoTo ErrorHandlerMyCell
Range("A1").Activate
Cells.Find(What:=mycell, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
On Error GoTo 0
ActiveCell.EntireRow.Cut
wbProjectJournal.Activate
Range("A1").Activate
If Range("A2") <> "" Then
GoTo NextCode2
NextCode2:
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Activesheet.Paste
wbGL.Activate
ActiveCell.EntireRow.Delete
Else
Range("A2").Select
Activesheet.Paste
End If
NextCode1:
Next mycell
ErrorHandlerMyCell:
Resume NextCode1
End Sub
Do you know that your code will run ErrorHandlerMyCell at the end irregardless of whether there's an error or not? It's not a separate module that is called only when there's error but part of the main program which gets triggered. Perhaps you can add a Exit Sub before ErrorHandlerMyCell
Exit Sub
ErrorHandlerMyCell:
Resume NextCode1
End Sub
The code have plenty of redundancies and it seems to be overwriting records copied in Row 3 when cell A2 in wbProjectJournal is empty.
I also suggest to set the worksheets as objects instead of the workbooks. Actually the code ends up working with whatever is the active sheet in the workbooks after they are activated. It could be working now if there is only one sheet or if the one active is the one required, but it’s just a coincidence, not a good practice.
One point to highlight is the excessive and incorrect use of what is intended to act as Error Handlers (see this page On Error Statement for a better understanding), also to improve use of objects see this With Statement
The code below should solve the issue, (have inserted comments to explain the changes):
Option Explicit
Sub TEST_Solution()
Dim wbProjects As Workbook, wbGL As Workbook, wbProjectJournal As Workbook
Dim rTrg As Range, rCll As Range, rCllTrg As Range
Dim rFnd As Range, vWhat As Variant
Set wbProjects = Workbooks("Expense Project Jobs.xlsx")
Set wbGL = Workbooks("GL.xml")
Set wbProjectJournal = Workbooks("Expense Project Journal.xlsx")
wbProjects.Activate
Rem Set Range from wbProjects\Project_Costs\Column F
'use [With] to perform several statements on the same object
'see https://msdn.microsoft.com/en-us/library/office/gg264723(v=office.15).aspx
With wbProjects.Sheets("Project_Costs").Columns(6)
Set rTrg = Range(.Cells(2), .Cells(Rows.Count).End(xlUp))
End With
Rem Search for the value of each cell in the no-empty cells of
For Each rCll In rTrg
Rem Set & Validate cell value
vWhat = rCll.Value2
If vWhat <> Empty Then
Rem Activate range to apply the FIND method
'Replace [1] with the name of the worksheet where the search is run
With wbGL.Sheets(1)
.Application.Goto .Cells(1), 1
Rem Set cell with found value
Set rFnd = .Cells.Find(What:=vWhat, After:=ActiveCell, _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not (rFnd Is Nothing) Then
Rem Activate range to apply the FIND method
'Replace [1] with the name of the worksheet where the search is performed
With wbProjectJournal.Sheets(1).Cells(2, 1)
If .Value2 = Empty Then
Rem A2 = Blank then Paste in row 2 only
rFnd.EntireRow.Copy
.PasteSpecial
Application.CutCopyMode = False
ElseIf .Offset(1).Value2 = Empty Then
Rem A3 = Blank then Paste in row 3 & delete record found
rFnd.EntireRow.Copy
.Offset(1).PasteSpecial
Application.CutCopyMode = False
rFnd.EntireRow.Delete
Else
Rem Paste below last row & delete record found
rFnd.EntireRow.Copy
.End(xlDown).Offset(1).PasteSpecial
Application.CutCopyMode = False
rFnd.EntireRow.Delete
End If: End With: End If: End With: End If: Next
End Sub
So I need simple vba script. I have 3 columns. I need to find each value from column C in Column A and offset value from column B right next to value from column C.
For this I can use VlookUp, I know.
But If there is more than one same value in Column A with different offset value from B, I need to put those all different values in the same row, right next to C column value.
thanks guys in advice
I'm using this kind of code but it works just with first match skipping others...
P.S. I changed columns
Sub Sample()
Dim ws As Worksheet
Dim DataRange As Range, UpdateRange As Range, aCell As Range, bCell As Range
On Error GoTo Err
Set ws = Worksheets("Missing_Subnets_21048_COPY")
Set UpdateRange = ws.Range("K6:K12")
Set DataRange = ws.Range("H6:H12")
For Each aCell In UpdateRange
Set bCell = DataRange.Find(What:=aCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not bCell Is Nothing Then
aCell.Offset(, 1) = bCell.Offset(, 1)
End If
Next
Exit Sub
Err:
MsgBox Err.Description
End Sub