I have data like this in different cells in column F: 3RG-1S,22,45YM+1W,32VC,23
How can I do to once I click on a cell in column F, in this case, rows 3, 22, 45, 32 and 23 get painted in yellow?
Please help, I've been trying to do this, but I don't know how to use those formulas within VBA
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim celda As Range
Dim rowvalue As Integer
Dim column As Integer
Dim comas As Integer
Dim positioncoma As Integer
Dim newpositioncoma As Integer
Dim contenidocelda As String
Dim i As Long
Dim NumberOfHits As Long
Dim e As Integer
If ActiveCell.value <> "" Then
Range("A1:F500").Interior.ColorIndex = xlNone
Set celda = ActiveCell
column = ActiveCell.column
If column = 6 Then 'Only works when clicking cells in column F
For i = 1 To Len(celda)
If Mid(celda, i, 1) = "," Then
NumberOfHits = NumberOfHits + 1
End If
Next
comas = NumberOfHits 'Gets the number of commas in the selected cell
positioncoma = 0 'counter in zero
If comas <> 0 Then 'Loop to find the first numbers for each value within commas and paint those rows in yellow
For e = 1 To comas
newpositioncoma = "=IFERROR(FIND(" & Chr(34) & "," & Chr(34) & "," & celda & "," & positioncoma & "+1),LEN(" & celda & "))"
contenidocelda = "=MID(" & celda & "," & positioncoma & "+1," & newpositioncoma & "-" & positioncoma & "-1)"
rowvalue = "=LEFT(" & contenidocelda & ", MATCH(FALSE, ISNUMBER(MID(" & contenidocelda & ", ROW(INDIRECT(" & Chr(34) & "1:" & Chr(34) & "&LEN(" & contenidocelda & ")+1)), 1) *1), 0) -1)"
Range("A" & rowvalue & ":F" & rowvalue).Interior.ColorIndex = 36
positioncoma = newpositioncoma
Next e
Else
rowvalue = "=LEFT(celda,MATCH(FALSE,ISNUMBER(MID(celda,ROW(INDIRECT(" & Chr(34) & "1:" & Chr(34) & "&LEN(celda)+1)),1)*1),0)-1)"
End If
Else
Range("A1:F500").Interior.ColorIndex = xlNone 'unpaint cells once click somewhere else
End If
Else
Range("A1:F500").Interior.ColorIndex = xlNone 'unpaint cells if ActiveCell is empty
End If
End Sub
At the moment I'm using the following code that highlights cells but only when I have a simple number as a value. I can't find a way to get the numbers 3, 22, 45, 32 and 23 from a string like this: 3RG-1S,22,45YM+1W,32VC,23.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rowvalue As Integer
Range("A4:xz90").Interior.ColorIndex = xlNone
If ActiveCell.column = 6 Then
rowvalue = ActiveCell.Row
Range("A" & rowvalue & ":xz" & rowvalue).Interior.ColorIndex = 19
If VarType(ActiveCell.Value) = 5 Then
rowvalue = ActiveCell.Value
Range("A" & rowvalue & ":xz" & rowvalue).Interior.ColorIndex = 35
End If
End If
End Sub
Example of my worksheet and result when I click cell F69
Dim v As Variant
Dim iRow As Long
Range("A1:F500").Interior.ColorIndex = xlNone
For Each v In Split(Range("f1"), ",")
iRow = Val(v)
If iRow > 0 Then
Range(Cells(iRow, "A"), Cells(iRow, "F")).Interior.Color = vbYellow
End If
Next
Related
i am trying to copy selected cells rows , together with the header over to another cell. however, the most i can copy is up to 4 rows, else i will receive the range of object global failed error message. may i know why i am unable to select 5 rows and above? thank you in advance.
Sub CopyPaste()
Dim NumRowSelected As Integer
Dim i As Integer
Dim currentCell As Range
Dim bottomCell As Range
Dim ToSelect As Range
Dim k As Integer
Dim selectedString As String
Windows("Book1.xlsx").Activate
Sheets("working").Select
NumRowSelected = Selection.Rows.Count
selectedString = "A1,B1,C1,D1,E1,F1,G1,H1,I1,J1,K1,L1,M1,N1,O1"
k = 2
i = 0
Set currentCell = Range("A2")
Set bottomCell = Range("A2").End(xlDown)
Do While k <= bottomCell.Row
For Each cell In Selection
If currentCell = cell Then
selectedString = selectedString & ",A" & k & ",B" & k & ",C" & k & ",D" & k & ",E" & k & ",F" & k & ",G" & k & ",H" & k & ",I" & k & ",J" & k & ",K" & k & ",L" & k & ",M" & k & ",N" & k & ",O" & k
i = i + 1
If i = NumRowSelected Then
Exit Do
End If
Exit For
End If
Next cell
k = k + 1
Set currentCell = Range("A" & k)
Loop
Set a = Range(selectedString)'error code shows here
a.Select
Range("A1").Activate
Selection.Copy
Range("Q1").Select
ActiveSheet.Paste
Selection.Copy
End Sub
The address you pass to the Range property is limited to 255 characters, which you will easily bypass with your method. You can condense it quite a lot since your cells are contiguous within a row by using:
selectedString = selectedString & ",A" & k & ":O" & k
and start with:
selectedString = "A1:O1"
but it would be safer to use a Range object with Union:
If a is Nothing then
Set a = Range("A" & k).Resize(1, 15)
else
set a = Union(a, Range("A" & k).Resize(1, 15))
end if
I have several columns that I need to concatenante, while the text styling for one column is kept intact and each column is concatenated in a new line (carriage return).
Col A text in bold, Col B text normal, Col C = concatenated col A content in bold + carriage return + col B content.
Using Concatenate formula in combination with CHAR(10) works but obviously the text styling isn't kept. VBA seems to be the way to go but I'm a total newbie at it.
I found the following code that does the concatenation, kees the styling but for the life of me I cant figure how to include a carriage return with vbCrLf in a string.
Sub MergeFormatCell()
Dim xSRg As Range
Dim xDRg As Range
Dim xRgEachRow As Range
Dim xRgEach As Range
Dim xRgVal As String
Dim I As Integer
Dim xRgLen As Integer
Dim xSRgRows As Integer
Dim xAddress As String
On Error Resume Next
xAddress = ActiveWindow.RangeSelection.Address
Set xSRg = Application.InputBox("Select cell columns to concatenate:", "Concatenate in Excel", xAddress, , , , , 8)
If xSRg Is Nothing Then Exit Sub
xSRgRows = xSRg.Rows.Count
Set xDRg = Application.InputBox("Select cells to output the result:", "Concatenate in Excel", , , , , , 8)
If xDRg Is Nothing Then Exit Sub
Set xDRg = xDRg(1)
For I = 1 To xSRgRows
xRgLen = 1
With xDRg.Offset(I - 1)
.Value = vbNullString
.ClearFormats
Set xRgEachRow = xSRg(1).Offset(I - 1).Resize(1, xSRg.Columns.Count)
For Each xRgEach In xRgEachRow
.Value = .Value & Trim(xRgEach.Value) & " "
Next
For Each xRgEach In xRgEachRow
xRgVal = xRgEach.Value
With .Characters(xRgLen, Len(Trim(xRgVal))).Font
.Name = xRgEach.Font.Name
.FontStyle = xRgEach.Font.FontStyle
.Size = xRgEach.Font.Size
.Strikethrough = xRgEach.Font.Strikethrough
.Superscript = xRgEach.Font.Superscript
.Subscript = xRgEach.Font.Subscript
.OutlineFont = xRgEach.Font.OutlineFont
.Shadow = xRgEach.Font.Shadow
.Underline = xRgEach.Font.Underline
.ColorIndex = xRgEach.Font.ColorIndex
End With
xRgLen = xRgLen + Len(Trim(xRgVal)) + 1
Next
End With
Next I
End Sub
The interest of the above code is that it allows the user to specify via an input box the cells range to concatenate and where to output the results.
Anyone can give me a hand and modify it so each new column goes in a new line after concatenation?
If you got a simplier solution I'm all for it as long as it works.
p.s. I'm running Excel 2013 if that matters.
This below code does not copy formatting, but it is concatenate both columns and bold the value appears in column A.
Option Explicit
Sub test()
Dim LastRow As Long, Row As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Row = 1 To LastRow
With .Range("C" & Row)
.Value = ThisWorkbook.Worksheets("Sheet1").Range("A" & Row).Value & vbNewLine & ThisWorkbook.Worksheets("Sheet1").Range("B" & Row).Value
.Characters(1, Len(ThisWorkbook.Worksheets("Sheet1").Range("A" & Row).Value)).Font.FontStyle = "Bold"
End With
Next Row
End With
End Sub
EDITED VERSION:
Option Explicit
Sub test()
Dim LastRow As Long, Row As Long
Dim strA As String, strB As String, strC As String, strD As String, strE As String, strF As String
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Row = 1 To LastRow
strA = .Range("A" & Row).Value
strB = .Range("B" & Row).Value
strC = .Range("C" & Row).Value
strD = .Range("D" & Row).Value
strE = .Range("E" & Row).Value
strF = .Range("F" & Row).Value
With .Range("G" & Row)
.Value = strA & vbNewLine & strB & vbNewLine & strC & vbNewLine & strD & vbNewLine & strE & vbNewLine & strF
.Characters(1, Len(strA)).Font.FontStyle = "Bold"
.Characters((Len(strA) + Len(strB) + 5), Len(strC)).Font.FontStyle = "Bold"
.Characters((Len(strA) + Len(strB) + Len(strC) + Len(strD) + 9), Len(strE)).Font.FontStyle = "Bold"
End With
Next Row
End With
End Sub
I'm trying to get the cells that contain match the certain text criteria I search for.
I keep getting the error
Run-Time error 424 Object required
on line 12
cell = Sheets("Sheet1").Range("A" & row_num)
and I'm not sure why?
Any and all help with this would be greatly appreciated!
Option Compare Text
Sub FindingColumn()
Dim Col1Rng As Range, Col3Rng As Range
Dim Column1Search As String, Column2Search As String, Column3Search As
String
row_num = 0
Column1Search = InputBox("Col 1 Criteria: ")
Do
DoEvents
row_num = row_num + 1
cell = Sheets("Sheet1").Range("A" & row_num)
If Col2Rng = Empty And InStr(cell, Column1Search) Then
Col2Rng = cell.Address(0, 0)
ElseIf InStr(cell, Column1Search) Then
Col2Rng = Col2Rng & "," & cell.Address(0, 0)
End If
Loop Until cell = ""
Range(Col2Rng).Select
End Sub
This should serve as the basis for what you're trying to do
Sub FindingColumn()
Dim Col1Rng As Range, Column1Search As String, foundCellCol1 As Range
Set Col1Rng = ActiveSheet.Range("A:A")
Column1Search = InputBox("Col 1 Criteria: ")
Set foundCellCol1 = Col1Rng.Find(What:=Column1Search)
If Not foundCellCol1 Is Nothing Then foundCellCol1.Select Else: MsgBox "Search term not found!"
End Sub
Can you generate a list in another location of all of the items that match?
Option Explicit
Sub FindingColumn()
Dim Col1Rng As Range, Column1Search As String, foundCellCol1 As Range, lastRow As Long, lastFoundRow As Long
lastRow = Range("A100000").End(xlUp).Row
Set Col1Rng = ActiveSheet.Range("A1:A" & lastRow)
Column1Search = InputBox("Col 1 Criteria: ")
Set foundCellCol1 = Col1Rng.Find(What:="*" & Column1Search & "*")
While Not foundCellCol1 Is Nothing
If Not foundCellCol1 Is Nothing Then
Range("B" & Range("B100000").End(xlUp).Row + 1) = foundCellCol1.Value
Set Col1Rng = ActiveSheet.Range("A" & foundCellCol1.Row & ":A" & lastRow)
lastFoundRow = foundCellCol1.Row
Set foundCellCol1 = Col1Rng.Find(What:="*" & Column1Search & "*")
If foundCellCol1.Row = lastFoundRow Then Set foundCellCol1 = Nothing
End If
DoEvents
Wend
End Sub
I have a macro I am running to update a report table in Excel but I keep getting an error on this particular line of code:
totalFieldsStart = Left(totalFieldsStart, Len(totalFieldsStart) - 1) & ")"
Here is a look at the entire Macro:
Function AppnSOFFormulasState(fTL As Range, fBR As Range)
Dim final As Worksheet
Dim aCol As Integer 'index for appn column
Dim dCol As Integer 'index for div column
Dim mCol As Integer 'index for mdep column
Dim appn As String
Dim st As String
Dim div As String
Dim mdep As String
Dim stateAdd As String
Dim ntlAdd As String
Dim totalFieldsStart As String 'cells to total will be separated
Dim totalFieldsAFP As String 'cells to total will be separated
Dim totalFieldsOBS As String 'cells to total will be separated
Dim subFields As Range 'cells to subtotal will be contiguous
Dim c As Range 'cell iterator
Set final = ThisWorkbook.Worksheets(1)
final.Activate
aCol = final.Range("A1").Column
dCol = final.Range("B1").Column
mCol = final.Range("C1").Column
'set top left to be first October cell for APPN
appn = final.Cells(fTL.Row, aCol)
st = Range("state_select").address
totalFieldsAFP = "=sum("
totalFieldsOBS = "=sum("
Set fTL = fTL.Offset(0, 3)
For Each c In final.Range(fTL, final.Cells(fBR.Offset(-1, 0).Row, fTL.Column))
If Not IsEmpty(final.Cells(c.Row, dCol)) Then
'the first line will have nothing for div, so the range part of the next if will fail
On Error GoTo SkipFirst
If final.Cells(c.Row, dCol) = final.Range(div) & sTotal Then
c.Formula = "=sum(" & subFields.address & ":" & c.Offset(-1, 0).address & ")"
c.Offset(0, 1).Formula = "=sum(" & subFields.Offset(0, 1).address & ":" & c.Offset(-1, 1).address & ")"
totalFieldsAFP = totalFieldsAFP & c.address & ", "
totalFieldsOBS = totalFieldsOBS & c.Offset(0, 1).address & ", "
Else
SkipFirst:
On Error GoTo 0
Set subFields = c
div = final.Cells(c.Row, dCol).address
End If
End If
If Not IsEmpty(final.Cells(c.Row, mCol)) Then
mdep = final.Cells(c.Row, mCol).address
stateAdd = "left(" & st & ",2) &" & appn & "&" & div & "&" & mdep
ntlAdd = appn & "&" & div & "&" & mdep
'AFP
c.Formula = "=iferror(VLOOKUP(" & stateAdd & ",state_lookup_sof,3,FALSE),0)"
'Obs
c.Offset(0, 1).Formula = "=iferror(VLOOKUP(" & stateAdd & ",state_lookup_sof,4,FALSE),0)"
End If
Next c
totalFieldsStart = Left(totalFieldsStart, Len(totalFieldsStart) - 1) & ")"
totalFieldsAFP = Left(totalFieldsAFP, Len(totalFieldsAFP) - 1) & ")"
totalFieldsOBS = Left(totalFieldsOBS, Len(totalFieldsOBS) - 1) & ")"
final.Cells(fBR.Row, fTL.Column).Formula = totalFieldsAFP
final.Cells(fBR.Row, fTL.Offset(0, 1).Column).Formula = totalFieldsOBS
End Function
Sub Button1_Click()
Dim Data1 As String
Dim Data2 As String
Dim sFinal As String
Dim sLeft As String
Dim sRight As String
'For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
Data1 = Range("A1").Value
Data2 = "-"
sLeft = Left(Data1, 2)
sRight = Right(Data1, Len(Data1) - 2)
sFinal = sLeft & Data2 & sRight
Range("A1").Value = sFinal
'Next i
End Sub
I am trying to loop trough values of column A to insert "-" after two characters in every cells... but my "For Next i" loop has error, how can I fix it?
This is better:
Sub Button1_Click()
Dim i As Long
Application.ScreenUpdating = False
i = 1
Do Until i > Range("A1048576").End(xlUp).Row
Range("A" & i).Value = Left(Trim(Range("A" & i).Value), 2) & "-" & Right(Trim(Range("A" & i).Value), Len(Trim(Range("A" & i).Value)) - 2)
i = i + 1
Loop
Application.ScreenUpdating = True
End Sub