I have this table that contain more than 6K rows.
I need a function, that will run on each "A" Column's cell
and check -> if cell on "b" is bold than copy it,
if not, copy the cell above it.
I fount this function on the internet, but im not using VB and it will be easier if someone that already know how to use VB functions in excel than learn it from the beginning.
this code replaces the G column cells with numbers, as you can see.
Sub BoldCells()
Dim TheRange As Range
Dim TheCell As Range
Set TheRange = Range("G1", Range("G65536").End(xlUp))
For Each TheCell In TheRange
If TheCell.Font.Bold = True Then
TheCell = 7
Else: TheCell = 0
End If
Next TheCell
End Sub
Help will be very appreciated, thank you!
I am not sure how efficient this is, but looks like working with 10 lines or so of data.
Sub test()
Dim rng As Range, str As String
Set rng = Range("b1")
str = ""
Do
If rng.Font.Bold Then
str = rng.Value
End If
rng.Offset(0, -1).Value = str
Set rng = rng.Offset(1, 0)
Loop Until IsEmpty(rng)
End Sub
Related
I am writing a check in/out program in excel and have gotten te request that if a line contains "|0|" it should get a different font color.
I've tried with Instr and Cells().Characters but I cannot seem to figure out how to do it.
The cells can have a variety of rows of text. Which is easy enough to solve with splitting them on a return and having a for loop loop, but I cannot seem to figure out how to assign a different font color to a row of text that contains the required value.
Image for illustration of the data:
How do I best solve this?
Added information:
The goal of this is that on button press the whole line of text where the |O| is would be collored differently. Other lines of text that do not have this will remain the same color.
Like in this image as a concept
[]
try this
Public Sub ExampleMainSub()
Dim cell As Range
For Each cell In Selection
If HasMySymbols(cell.Value) Then
WorkWithCellContent cell
Else
cell.Font.ColorIndex = xlAutomatic
cell.Font.TintAndShade = 0
End If
Next cell
End Sub
Private Sub WorkWithCellContent(ByVal cell As Range)
Dim arr As Variant
arr = Split(cell.Value, Chr(10))
Dim firstPosOfRow As Long
firstPosOfRow = 1
Dim subLine As Variant
For Each subLine In arr
If HasMySymbols(subLine) Then
cell.Characters(start:=firstPosOfRow, Length:=Len(subLine)).Font.Color = vbRed
Else
cell.Characters(start:=firstPosOfRow, Length:=Len(subLine)).Font.ColorIndex = xlAutomatic
End If
firstPosOfRow = firstPosOfRow + Len(subLine) + 1 '+1 is needed
Next subLine
End Sub
Private Function HasMySymbols(ByVal somestring As String) As Boolean
HasMySymbols = InStr(1, somestring, "|0|") > 0
End Function
Try this. It works for me.
Sub ChangeRowFontColour()
Dim rng As Range
Dim TextToFind As String
Dim FirstFound As String
TextToFind = "Specific Text"
With ActiveSheet.UsedRange
Set rng = .Cells.Find(TextToFind, LookIn:=xlValues)
If Not rng Is Nothing Then
FirstFound = rng.Address
Do
rng.EntireRow.Font.ColorIndex = 3
For Each part In rng
lenOfPart = Len(part)
lenTextToFind = Len(TextToFind)
For i = 1 To lenOfPart
tempStr = Mid(part, i, lenTextToFind)
If tempStr = TextToFind Then
part.Characters(Start:=i, Length:=lenTextToFind).Font.ColorIndex = 0
End If
Next i
Next
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> FirstFound
End If
End With
End Sub
So here's the code. I have a calendar with dates in B4:H9. I want to change the color of the cells if the those dates are in a list (column, on different worksheet).
This might be a bit heavy to run if there are many different dates in the worksheet, but that doesn't matter.
What am I doing wrong here? It keeps giving me different error codes, when trying different things.
Sub check_Click()
Dim area As Range
Dim item1 As Range
Dim item2 As Range
Dim sheet As Worksheet
Dim columnlist As Range
sheet = Range("E2").Value
area = Range("B4:H9")
columnlist = Worksheets(sheet).Range("A2:A" & Rows.Count)
For Each item1 In area
For Each item2 In columnlist
If item1.Value = item2.Value Then
item1.Interior.ColorIndex = RGB(255, 255, 0)
End If
Next item2
Next item1
End Sub
As SuperSymmetry mentioned, when you define objects (e.g. ranges, sheets) you need to use the Set keyword. I will not get into that explanation. However few things that I would like to mention...
Try and give meaningful variable names so that you can understand what are they for.
Work with objects so that your code knows which sheet, which range are you referring to.
No need of 2nd loop. Use .Find to search for your data. It will be much faster
To set RGB, you need .Color and not .ColorIndex
Is this what you are trying? (Untested)
Option Explicit
Sub Check_Click()
Dim rngData As Range
Dim rngReference As Range
Dim aCell As Range
Dim matchedCell As Range
Dim ws As Worksheet
Dim lastRow As Long
Dim worksheetName As String
'~~> Change the sheet name accordingly
worksheetName = ThisWorkbook.Sheets("Sheet1").Range("E2").Value
Set ws = ThisWorkbook.Sheets(worksheetName)
With ws
'~~> Find the last row in Col A
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rngData = .Range("B4:H9")
Set rngReference = .Range("A2:A" & lastRow)
'~~> Loop through your data and use .Find to check if the date is present
For Each aCell In rngData
Set matchedCell = rngReference.Find(What:=aCell.Value, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not matchedCell Is Nothing Then
'~~> Color the cell
matchedCell.Interior.Color = RGB(255, 255, 0)
End If
Next aCell
End With
End Sub
This should do the trick, I don't like leaving ranges without their sheet, but since I believe you are using a button, there should be no problem:
Option Explicit
Sub check_Click()
'We are going to use a dictionary, for it to work you need to:
'Go to Tools-References-Check the one called: Microsoft Scripting Runtime
Dim DatesToChange As Dictionary: Set DatesToChange = LoadDates
Dim area As Range: Set area = Range("B4:H9")
Dim item As Range
For Each item In area
If DatesToChange.Exists(item.Value) Then
item.Interior.Color = RGB(255, 255, 0)
End If
Next item
End Sub
Private Function LoadDates() As Dictionary
Set LoadDates = New Dictionary
Dim arr As Variant: arr = ThisWorkbook.Sheets(Range("E2")).Range("A:A")
Dim i As Long
For i = 2 To UBound(arr)
'This here will break the loop when finding an empty cell in column A
If arr(i, 1) = vbNullString Then Exit For
'This will add all your dates in a dictionary (avoiding duplicates)
If Not LoadDates.Exists(arr(i, 1)) Then LoadDates.Add arr(i, 1), 1
Next i
End Function
When you define objects (e.g. ranges, sheets) you need to use the Set keyword
Set area = Range("B4:H9")
Set columnlist = Worksheets(sheet).Range("A2:A" & Rows.Count)
Worksheets() accepts either an Integer or a String. Therefore, sheet should be of Type String
Dim sheet As String
You're also setting columnlist to the whole column in the sheet so you're looping hundreds of thousands more times unncessarily. Change it to
With Worksheets(sheet)
Set columnlist = .Range(.Range("A2"), .Range("A" & Rows.Count).Offset(xlUp))
End With
The above should fix the errors in your code and make it run a little faster. However, there's still big room for improvment in the efficiency of the code. For example, instead of changing the colour inside the loop, you should build a range and set the colour one time after the loop.
Also consider resetting the colour at the beginning of the code with
area.Interior.Pattern = xlNone
I would personally go with conditional formatting as #SiddharthRout suggested in the comments.
Edit following comment
Here's my rendition
Sub check_Click()
Dim dStart As Double
dStart = Timer
Dim rngCalendar As Range
Dim vCalendar As Variant
Dim shtDates As Worksheet
Dim vDates As Variant, v As Variant
Dim i As Long, j As Long
Dim rngToColour As Range
' Change the sheet name
With ThisWorkbook.Sheets("Calendar")
Set rngCalendar = .Range("B4:H9")
vCalendar = rngCalendar.Value
Set shtDates = ThisWorkbook.Sheets(.Range("E2").Value)
End With
With shtDates
vDates = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp)).Value
End With
For i = 1 To UBound(vCalendar, 1)
For j = 1 To UBound(vCalendar, 2)
For Each v In vDates
If v <> vbNullString And v = vCalendar(i, j) Then
If rngToColour Is Nothing Then
Set rngToColour = rngCalendar.Cells(i, j)
Else
Set rngToColour = Union(rngToColour, rngCalendar.Cells(i, j))
End If
Exit For
End If
Next v
Next j
Next i
rngCalendar.Interior.Pattern = xlNone
If Not rngToColour Is Nothing Then
rngToColour.Interior.Color = RGB(255, 255, 0)
End If
MsgBox "Time taken: " & Format(Timer - dStart, "0.0000s")
End Sub
With a list of 2500 dates it took 0.0742s on my machine.
I have formulas throughout a workbook that are returning an output if matched with X and "" if not. I am new to VBA and macro's and unsure of where to begin. But my goal is to have a macro that I could run that clears the formula if it is blank or "" across multiples sheets. I would note, I only want it to do this in certain columns of each sheet.
Example:
Sheet 1 has the formula in cells H10:K20, while Sheet 2 has the formula in AV8:AV400, etc. etc. The goal being to have it recognize "Sheet 1" is a range of H10:K20 where it would erase, Sheet 2 is AV8:AV400.
Any help would be greatly appreciated!
I had found another question that was kind of similar, but I could not figure out how to make it recognize different sheet names or specific ranges within my file. I have pasted the code I had found and tried to use below as well as the link here.
How to clear cell if formula returns blank value?
Sub ClearCell()
Dim Rng As Range
Set Rng = ActiveSheet.Range("A1")
Dim i As Long
For i = 1 To 10
If Rng.Cells(i,1) = "" Then
Rng.Cells(i,1).ClearContents
End If
Next i
End Sub
Maybe something very basic:
Sub ClearEmptyFormulas()
Dim ws As Worksheet
Dim rng As Range, cl As Range
For Each ws In ThisWorkbook.Sheets(Array("Sheet1", "Sheet2")) 'Extend the array or loop all worksheets
Select Case ws.Name
Case "Sheet1"
Set rng = ws.Range("H10:K20")
Case "Sheet2"
Set rng = ws.Range("AV8:AV400")
'Etc
End Select
For Each cl In rng
If cl.Value = "" Then
cl.ClearContents
End If
Next cl
Next ws
End Sub
Or even a bit simpler:
Sub ClearEmptyFormulas()
Dim rng As Range, cl As Range
Dim arr1 As Variant: arr1 = Array("Sheet1", "Sheet2")
Dim arr2 As Variant: arr2 = Array("H10:K20", "AV8:AV400")
For x = 0 To 1
Set rng = Sheets(arr1(x)).Range(arr2(x))
For Each cl In rng
If cl.Value = "" Then
cl.ClearContents
End If
Next cl
Next x
End Sub
Using VBA in excel, I am wanting to incorporate the formula located in column "O", shown below, for all B rows that have a value starting at B9. Please reference the image.
=""&D9&" "&I9&" (MK NO. "&B9&")"
This should do what your are looking for.
Sub Pasteformula()
Dim LookupRange As Range
Dim c As Variant
Application.ScreenUpdating = False
Set LookupRange = Range("B9:B500") ' Set range in Column B
For Each c In LookupRange 'Loop through range
If c.Value <> "" Then 'If value in B is empty then
Cells(c.Row, 15).FormulaR1C1 = _
"=""""&RC[-11]&"" ""&RC[-6]&"" (MK NO. ""&RC[-13]&"")""" 'Apply formula
End If
Next c
Application.ScreenUpdating = True
End Sub
Set the range and enter the formula, then change the range to values.
Sub Button1_Click()
Dim rng As Range
Set rng = Range("O9:O" & Cells(Rows.Count, "B").End(xlUp).Row)
rng.Formula = "=CONCATENATE(D9,"" "",I9,"" (MK NO. "",B9,"")"")"
rng.Value = rng.Value
End Sub
from your narrative I get that you already have the proper formula in O9, hence you could use AutoFill() method of Range object:
Range("O9").AutoFill Range("B9", Cells(Rows.Count, "B").End(xlUp)).Offset(,13)
So I'm fairly new to VBA, and I have been struggling with trying to get my macro to work.
Essentially what I'm trying to do is have a program read down a column, and for every "X" located in that column, the corresponding hyperlink in the adjacent column will be selected.
Sub Select_Hyperlinks()
Dim rng As Range, cell As Range, sel As Range
Dim sht As Worksheet
For x = 1 To 6
Set sht = Sheets("Generator")
Set sel = cell.Offset(-1, 0)
Set rng = Intersect(sht.Range("D4:D9"), sht.UsedRange)
For Each cell In rng.Cells
If (cell.Value) <> "X" _
Then
If sel Is Nothing Then
Set sel = cell.Offset(-1, 0)
sel.Select
End If
Next cell
End If
Next x
End Sub
I also tried a simpler idea using the Find and FindNext functions and for each X, I tried to get it to select and activate the cell in the adjacent column, but also with no luck. It seems I always get snagged up on the .Offset function.
EDIT:
Here's what I've managed to come up with, after some further research. I've adapted this from a macro designed to delete all empty rows.
Sub AutoOpen()
Dim xlastcell As Integer
Dim xcell As Integer
xcell = 1
Range("C200").End(xlUp).Select
xlastcell = ActiveCell.Cells 'This used to say ActiveCell.Row but I want a single cell'
Do Until xcell = xlastcell
If Cells(xcell, 1).Value = "X" Then
Cells(x, 1).Select
ActiveCell.Offset(0, -1).Select 'I'm also unable to get this function to work'
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
xcell = xcell - 1
xlastcell = xlastcell - 1
End If
xcell = xcell + 1
Loop
End Sub
Are you saying that if there is an X in the one column, you want to open the hyperlink?
EDIT:
Use this and change things to match your variables.
Sub asdhkl()
Dim c As Hyperlink
Dim i As Range
For Each i In Sheets(1).Range("b1:b3")
If i = "x" Then
Set c = i.Offset(0, -1).Hyperlinks(1)
c.Follow
End If
Next i
End Sub