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
Related
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
I have a some part of the codes of a macro it's working below changing of the cell value. But I want to replace them as linking a command button + getting data from a closed workbook. Can someone help me about re-edit them?
Thank you for help!
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Chck As Integer, Cnt As Integer
Dim Save As String
Dim Subjt As Integer
If Not Intersect(Range("A1"), Target) Is Nothing And Not Target = "" Then
With Workbooks("Data2.xlsm").Worksheets("Datas")
Application.EnableEvents = False
Worksheets("Sheet1").Cells.Clear
For Chck = 2 To .Cells(Rows.Count, "C").End(xlUp).Row
Select Case .Cells(Chck, "C")
Case "Number"
Subjt = Chck
Case ""
If Save <> "" Then
Save = "C" & Subjt & ":Q" & Subjt & Save
.Range(Save).Copy
Cnt = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
If Cnt > 1 Then Cnt = Cnt + 2
Worksheets("Sheet1").Range("A" & Cnt).PasteSpecial
Save = ""
End If
Case Target
If .Cells(Chck, "B") = "Number" Then Save = Save & ", C" & Chck & ":Q" & Chck
End Select
Next
Application.EnableEvents = True
End With
End If
End Sub
Try this in a regular module:
EDIT: made a few fixes
Sub CopyDataValues()
Dim Chck As Long, Cnt As Long
Dim Save As String
Dim Subjt As Long, valA1
Dim ws1 As Worksheet, wsData As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set wsData = Workbooks("Data2.xlsm").Worksheets("Datas")
Cnt = ws1.Range("A" & Rows.Count).End(xlUp).Row
Cnt = Cnt + 2
valA1 = ws1.Range("A1").Value
If Len(valA1) > 0 Then
With wsData
Application.EnableEvents = False
'ws1.Cells.Clear
For Chck = 2 To .Cells(Rows.Count, "C").End(xlUp).Row
Select Case .Cells(Chck, "C")
Case "NUMBER"
Subjt = Chck
Case ""
If Save <> "" Then
Save = "C" & Subjt & ":Q" & Subjt & Save
.Range(Save).Copy ws1.Range("A" & Cnt)
Cnt = Cnt + 2
Save = ""
End If
Case valA1
If .Cells(Chck, "B") = "REAL" Then
Debug.Print "matched " & valA1 & " on row " & Chck
Save = Save & ", C" & Chck & ":Q" & Chck
End If
End Select
Next
Application.EnableEvents = True
End With
End If
End Sub
Change Private Sub to Sub only and assign the macro to your related button.
For the workbook first, you have to create an excel object to get the closed workbook in it.
the macro below takes two cell values (from first and second column)
and displays the column and there cell content in a Pop up Form
Im trying to add the condition that only the column and cell value is displayed if the cell contains value.
something like that =IF(A1<>"",result,"")
but I dont know how to implement that for all cells not only for a specific one.
Option Explicit
Const rangeForSearch = "G2"
Const rowTitles = 4
Dim arrTmp
Dim lastRow As Long, lastColumn As Long
Dim textForSearch As String, textForSearch_withoutSpaces As String
Dim strTmp As String
Dim i As Long, j As Long
Sub searchPerson()
Application.ScreenUpdating = False
With ActiveSheet
textForSearch = .Range(rangeForSearch)
If textForSearch = "" Then
MsgBox "Input text in cell """ & rangeForSearch & """ and try again!", vbCritical
Application.ScreenUpdating = True
Exit Sub
End If
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
lastColumn = .Cells(rowTitles, .Columns.Count).End(xlToLeft).Column
If lastRow <= rowTitles Or lastColumn <= 2 Then
MsgBox "Dataset is wrong! Check it and try again!", vbCritical
Application.ScreenUpdating = True
Exit Sub
End If
arrTmp = .Range(.Cells(rowTitles, "A"), .Cells(lastRow, lastColumn))
End With
'---------------------------------------
textForSearch_withoutSpaces = Replace(textForSearch, " ", "")
For i = LBound(arrTmp, 1) + 1 To UBound(arrTmp, 1)
strTmp = Replace(arrTmp(i, 1) & arrTmp(i, 2), " ", "")
If StrComp(textForSearch_withoutSpaces, strTmp, vbTextCompare) = 0 Then Exit For
Next i
If i = UBound(arrTmp, 1) + 1 Then
strTmp = textForSearch & vbCrLf & vbCrLf & "No dataset!"
Else
strTmp = textForSearch
For j = 3 To lastColumn
strTmp = strTmp & vbCrLf & vbCrLf & arrTmp(1, j) & ": " & arrTmp(i, j)
Next j
End If
Application.ScreenUpdating = True
MsgBox strTmp, , "Result"
End Sub
maybe
For j = 3 To lastColumn
If Not IsEmpty(arrTmp(i, j)) Then strTmp = strTmp & vbCrLf & vbCrLf & arrTmp(1, j) & ": " & arrTmp(i, j)
Next j
The aim is to find the circularity between value in column c and all values obtained from updated "firstvalue" variable which are comma separated and stored in column "M".
Sub circular()
Dim rng As Range, rng2 As Range, firstvalue As String, secondvalue As String
Set sh = ThisWorkbook.Worksheets("Sheet1")
lr = sh.Range("C" & Rows.Count).End(xlUp).Row
For Each rng In sh.Range("C5:C" & lr) 'iterating over each cell in column "c" from C5 till lastrow "lr".
firstvalue = rng.Offset(0, 10).value 'Corresponding cell value which is comma seperated in column
"M" i:e after 10 columns from "C".
Dim n As Variant
For Each n In Split(firstvalue, ",") 'Looping through each value obtained from split function.
Set rng2 = sh.Range("C5:C" & lr).Find(Trim(n), LookIn:=xlValues) 'Finding that split value again
in column "C".
If Not rng2 Is Nothing Then 'if exists in column c then get.
secondvalue = rng2.Offset(0, 10).value 'corresponding cell values.
firstvalue = firstvalue & "," & secondvalue 'now first value is concatnated
with initial firstvalue
End If
Next n
MsgBox firstvalue
'Now i want to itterate over updated "firstvalue" in split function and this goes on in circular
fashion until rng value exists in firstvalue.
Next rng 'then change next rng and continue the above whole process for this value and so on.
End Sub
This code is working for initial firstvalue, can any one suggest any method to iterate over updated first value.
I'm not sure if I understand your goal exactly, but this code should find all predecessors for each task:
Sub circular()
Dim sh As Worksheet
Dim rTask As Range
Dim oCell As Range
Dim oFound As Range
Dim lr As Long, j As Long
Dim aPredecessors As Variant
Dim sCurTask As String
Dim secondValue As String
Set sh = ThisWorkbook.Worksheets("Sheet1")
lr = sh.Range("C" & Rows.Count).End(xlUp).Row
Set rTask = sh.Range("C5:C" & lr)
For Each oCell In rTask
sCurTask = Trim(oCell.Text)
aPredecessors = getPredecessors(Trim(oCell.Offset(0, 10).Text))
j = LBound(aPredecessors)
Do Until j > UBound(aPredecessors)
secondValue = aPredecessors(j)
If sCurTask = secondValue Then
ReDim Preserve aPredecessors(j)
Debug.Print "Task '" & sCurTask & "': Cyclic link '" & secondValue & "' for '" & Join(aPredecessors, ",") & "'!"
aPredecessors(j) = aPredecessors(j) & " !!!"
Else
If secondValue <> vbNullString Then
Set oFound = rTask.Find(secondValue, LookIn:=xlValues)
If oFound Is Nothing Then
ReDim Preserve aPredecessors(j)
Debug.Print "Task '" & sCurTask & "': Task '" & secondValue & "' for '" & Join(aPredecessors, ",") & "' not found!"
aPredecessors(j) = aPredecessors(j) & " ???"
Else
Call addNewTasks(aPredecessors, Trim(oFound.Offset(0, 10).Text))
End If
End If
End If
j = j + 1
Loop
oCell.Offset(0, 11).Value = Join(aPredecessors, ",")
Next oCell
End Sub
Function getPredecessors(sPredecessors As String)
Dim i As Long
Dim aTemp As Variant, sRes As String
Dim sTest As String
sRes = vbNullString
aTemp = Split(sPredecessors, ",")
For i = LBound(aTemp) To UBound(aTemp)
sTest = Trim(aTemp(i))
If InStr("," & sRes & ",", "," & sTest & ",") = 0 Then sRes = sRes & sTest & ","
Next i
If Len(sRes) > 1 Then sRes = Left(sRes, Len(sRes) - 1)
getPredecessors = Split(sRes, ",")
End Function
Sub addNewTasks(aData As Variant, sPredecessors As String)
Dim i As Long, uB As Long
Dim aTemp As Variant
Dim sTest As String, sValid As String
aTemp = Split(sPredecessors, ",")
If UBound(aTemp) >= 0 Then ' Not empty
sValid = "," & Join(aData, ",") & ","
For i = LBound(aTemp) To UBound(aTemp)
sTest = Trim(aTemp(i))
If sTest <> vbNullString Then
If InStr(sValid, "," & sTest & ",") = 0 Then
uB = UBound(aData) + 1
ReDim Preserve aData(uB)
aData(uB) = sTest
sValid = "," & Join(aData, ",") & ","
End If
End If
Next i
End If
End Sub
I have a lot of string which can contain italic font. I want to copy this string with this font. In each new string I have bold word
Example:
BIG STRING:
I tried:
Public Function GetDefinition(ByVal rngText As Range) As String
Dim theCell As Range
Set theCell = rngText.Cells(1, 1)
For I = 1 To Len(theCell.Value)
If theCell.Characters(I, 1).Font.Bold = False Then
If theCell.Characters(I + 1, 1).Text = " " Then
theChar = theCell.Characters(I, 1).Text
Else
theChar = theCell.Characters(I, 1).Text
End If
Results = Results & theChar
End If
Next I
GetDefinition = Results
End Function
I think you could use this:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long, j As Long, PositionOfDot As Long
With ThisWorkbook.Worksheets("Sheet1")
'Find last row of column A
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop from row 1 to lastrow
For i = 1 To LastRow
'Copy paste from column A to C keeping formatting
.Range("A" & i).Copy .Range("C" & i)
'Find the position of "."
PositionOfDot = InStr(1, .Range("A" & i), ".")
'Delete characters starting from the first one up to PositionOfDot+1
.Range("C" & i).Characters(1, PositionOfDot + 1).Delete
Next i
End With
End Sub
Results:
If your bold string always ends with a dot this will do it for you:
Option Explicit
Public Function GetDefinition(ByVal rngText As Range) As String
Dim SplitBold As Variant
SplitBold = Split(rngText, ". ")
GetDefinition = Trim(SplitBold(1))
End Function