Private Sub CommandButton22_Click()
row_number = 6
Do
DoEvents
row_number = row_number + 1
item_description = ActiveSheet.Range("B" & row_number)
If InStr(item_description, "Direct Credit") > 0 Then
item_description = ActiveCell.Activate
ActiveCell.Value = Right(ActiveCell, Len(ActiveCell) - 21)
End If
Loop Until item_description = B1000
End Sub
Hi,
I need to trim first 21 characters if the specific cell starts with "Direct Credit"?
There is something wrong in my coding after "Then" in If...
Can Some one help please?
See if this helps. If so please mark the answer as answered.
Public Sub MyTrim()
Const STARTS_WITH_STR As String = "Direct Credit"
Const TRIM_NUM As Integer = 21
Dim sht As Worksheet
Dim range As range
Dim cell As range
Dim sText As String
Dim iPos As Integer
Dim i As Integer
Set sht = ActiveSheet
' loop for 1000 rows
For i = 1 To 1000
' for each row, get the cell in column "B"
Set cell = sht.Cells(i, "B")
' get the text of the cell with triming blanks on both side of the string
sText = Trim(cell.Text)
' Search for a sub string. It does a text based compare (vbTextCompare)
' meaning- it will look for "Direct Credit" and also for "DIRECT CREDIT" and
' every thing in between (for example: DIREct Credit, .....)
iPost = InStr(1, sText, STARTS_WITH_STR, vbTextCompare)
' if the cell starts with the sub string above
If (iPos = 1) Then
' remove the 21 first chars
sText = Mid(sText, TRIM_NUM + 1)
cell.Value = sText
End If
Next
End Sub
Private Sub CommandButton23_Click()
Dim c As Range
For Each c In Range("B6:B1200")
With c
If Left(.Value, 13) = "Direct Credit" Then .Value = Right(.Value, Len(.Value) - 21)
End With
Next c
End Sub
Related
I have been searching for a while now a code to help me to extract superscript characters (number 1 and 2) that are either in the middle or at the end of a string in column A. I need to cut them from the string and paste them into the same row, but on column C as a normal number.
I did not find any suitable solutions I could evev try. So I do not have any code because I do not know where to start. My data will have always less than 500 lines and has the same structure, but lines with superscript change.
Does anyone know to solve this problem please? Thanks a lot.
I would really appreciate the help.
Desired output: for every row where there is a superscript, cut it from string in Column A and paste it in column C as a normal number..
Sub extractSuperscript()
Dim rng As Range
Dim cell As Range
Dim i As Long
Dim j As Long
Dim result As String
' Define the range to process
Set rng = Range("A1:A10")
' Loop through each cell in the range
For i = 1 To rng.Cells.Count
Set cell = rng.Cells(i)
result = ""
' Loop through each character in the cell
For j = 1 To Len(cell.Value)
' Check if the character is a superscript 1 or 2
If Mid(cell.Value, j, 1) = "¹" Or Mid(cell.Value, j, 1) = "²" Then
' If the character is a superscript 1, add a 1 to the result string
If Mid(cell.Value, j, 1) = "¹" Then
result = result & "1"
' If the character is a superscript 2, add a 2 to the result string
ElseIf Mid(cell.Value, j, 1) = "²" Then
result = result & "2"
End If
End If
Next j
' Paste the result string into column C and remove the superscript from column A
cell.Offset(0, 2).Value = result
cell.Value = Replace(cell.Value, "¹", "")
cell.Value = Replace(cell.Value, "²", "")
Next i
End Sub
Let me know if this works
Let me know if the following works:
Option Explicit
Sub Superscript()
Application.ScreenUpdating = True
Dim wb As Workbook
Dim ws As Worksheet
Dim rngSuperscript As Range, c As Range
Dim iCount As Integer
Dim MyString As String
Set wb = ThisWorkbook
'Set it to sheet name where your data is
Set ws = wb.Sheets("Test")
'Change it to reflect your data
Set rngSuperscript = ws.Range("A2:A11")
For Each c In rngSuperscript
'temp text variable
MyString = c.Value
'loop through the string value
For iCount = 1 To Len(MyString)
'check if it is numeric
If IsNumeric(Mid(MyString, iCount, 1)) Then
'combine with the C column value (if any)
c.Offset(0, 2).Value = CLng(c.Offset(0, 2).Value & Mid(MyString, iCount, 1))
End If
Next
Next c
Application.ScreenUpdating = False
End Sub
I am trying to have a macro to run through a column of data and insert a row for every instance it counts a "," so for example it would insert another 3 rows above Joanne
I currently have this code below but it doesn't work and im not sure im on the right track for it as I think it is looking for "," to only be the only contents in the cell? Any help/guidance would be greatly appreciated.
Sub InsertRow()
Dim cell As Range
For Each cell In Range("E2:E9999")
If cell.Value = "," Then
cell.EntireRow.Insert
End If
Next cell
End Sub
Insert As Many Rows As There Are Commas
Option Explicit
Sub InsertCommaRows()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
Application.ScreenUpdating = False
Dim cString As String
Dim CommasCount As Long
Dim r As Long
For r = lRow - 1 To 2 Step -1
Debug.Print ws.Cells(r, "E").Address(0, 0)
cString = CStr(ws.Cells(r, "E").Value)
CommasCount = Len(cString) - Len(Replace(cString, ",", ""))
If CommasCount > 0 Then
ws.Cells(r + 1, "E").Resize(CommasCount).EntireRow _
.Insert xlShiftDown, xlFormatFromLeftOrAbove
End If
Next r
Application.ScreenUpdating = True
MsgBox "Comma-rows inserted.", vbInformation
End Sub
This code counts the commas then inserts the same number of rows immediately below the current cell.
Sub InsertRow()
Dim cell As Range
Dim iCommas As Integer
For Each cell In ActiveSheet.Range("E2:E9999")
iCommas = Len(cell.Value) - Len(Replace(cell.Value, ",", ""))
If iCommas > 0 Then
cell.Offset(1).Resize(iCommas).EntireRow.Insert xlDown
End If
Next cell
End Sub
The excel cell has a formula of form =SUM(I1:I5). How can we convert it into its explicit form:
=I1+I2+I3+I4+I5
Another approach with .Precedents:
Sub expandSUM()
Range("A1").Formula = "=SUM(I1:I5)" 'the formula must be in the cell
Output = "=SUM("
For Each cl In Range("A1").Precedents
Output = Output & "+" & cl.Address(False, False)
Next
Debug.Print Replace(Output, "(+", "(") & ")"
End Sub
This feels like a post on Code Golf. Here's my version of a function that can do this.
Function ExplicitSum(ByVal expression As String) As String
Dim strStart As Long, strEnd As Long
strStart = InStr(1, UCase(expression), "SUM(") + 4
If strStart = 0 Then
'SUM not found
ExplicitSum = expression
Exit Function
End If
strEnd = InStr(strStart + 1, expression, ")")
If strEnd = 0 Then
'closing bracket not found
ExplicitSum = expression
Exit Function
End If
Dim LeftText As String, RightText As String, AddressText As String
LeftText = Replace(Left(expression, strStart - 1), "sum(", "(", Compare:=vbTextCompare)
AddressText = Mid(expression, strStart, strEnd - strStart)
RightText = Right(expression, Len(expression) - strEnd + 1)
If InStr(1, UCase(RightText), "SUM(") <> 0 Then
'Recursion will handle multiple sums in the same formula
RightText = ExplicitSum(RightText)
End If
Dim SumRange As Range
On Error Resume Next
Set SumRange = Range(AddressText)
On Error GoTo 0
If SumRange Is Nothing Then
'Invalid AddressText - Named Ranges or Indirect reference
ExplicitSum = LeftText & AddressText & RightText
Exit Function
End If
Dim Addresses() As String
ReDim Addresses(1 To SumRange.Cells.Count)
Dim cell As Range, i As Long: i = 1
For Each cell In SumRange
Addresses(i) = cell.Address(False, False)
i = i + 1
Next cell
ExplicitSum = LeftText & Join(Addresses, "+") & RightText
End Function
Examples of how to use the function:
Sub test()
MsgBox ExplicitSum("=5+sum(A1:D1)/20")
'Displays "=5+(A1+B1+C1+D1)/20"
End Sub
Sub ExampleUsage()
'Put the formula back into the cell after transforming
Range("E1").Formula = ExplicitSum(Range("E1").Formula)
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'Run on every cell with SUM in its formula
If LCase(Target.Cells(1,1).Formula) Like "*sum(*" Then Target.Cells(1,1).Formula = ExplicitSum(Target.Cells(1,1).Formula)
End Sub
Will work with complex formulas.
Will work with multiple SUMS in the same formula.
Will work with Named Ranges inside the Sum.
I wrote a function to do this via string manipulations.
I tested with
Before =SUM(C2:C4,E2:G2,D7:E8)
After =$C$2+$C$3+$C$4+$E$2+$F$2+$G$2+$D$7+$E$7+$D$8+$E$8
Usage, call ExpandSum() with the target cell as an argument
Public Sub ExpandSum(ByVal r_target As Range)
Dim f As String
f = Mid(r_target.Formula, 2)
' Is it a SUM function
If Left(f, 3) = "SUM" Then
' Take the arguments of SUM
f = Mid(f, 5, Len(f) - 5)
' make an array of string with each
' arument
Dim parts() As String
parts = Split(f, ",")
Dim i As Long, n As Long
n = UBound(parts) + 1
Dim rng As Range, cl As Range
Dim col As New Collection
For i = 1 To n
' for each argument find the range of cells
Set rng = Range(parts(i - 1))
For Each cl In rng
' Add each cell in range into a list
col.Add cl.Address
Next
Next i
' Transfer list to array
ReDim parts(0 To col.Count - 1)
For i = 1 To col.Count
parts(i - 1) = col(i)
Next i
' Combine parts into one expression
' ["A1","A2","A3"] => "A1+A2+A3"
f = Join(parts, "+")
r_target.Formula = "=" & f
End If
End Sub
Example of calling with the current selection
Public Sub ThisExpandSum()
Call ExpandSum(Selection)
End Sub
Caveats I don't know how it will behave if the sum contains literal values, or cells from different sheets. That can be functionality to be added later.
Use the next function, please:
Function SUMbyItems(strFormula As String) As String
If strFormula = "" Then Exit Function
Dim rng As Range, Ar As Range, c As Range, strF As String
Set rng = Range(left(Split(strFormula, "(")(1), Len(Split(strFormula, "(")(1)) - 1))
For Each Ar In rng.Areas
For Each c In Ar.cells
strF = strF & c.Address(0, 0) & "+"
Next c
Next
strF = left(strF, Len(strF) - 1)
SUMbyItems = "=SUM(" & strF & ")"
End Function
It can be used, selecting a cell having a SUM formula containing a range and run the next Sub:
Sub testSumByItems()
Debug.Print SUMbyItems(ActiveCell.Formula)
End Sub
If it returns what you want and you need changing the range formula with its expanded version, you can use (in the above testing Sub):
ActiveCell.Formula = SUMbyItems(ActiveCell.Formula)
I would like to change the color of a text in a cell in MS Excel like the conditioned formatting. I have different text in one cell, e.g. "WUG-FGT" or "INZL-DRE". I would like to format the cells (all cells in my workshhet), that a defined text like "WUG-FGT" appears red and the other text "INZL-DRE" green, but the text is in the same cell. With "sandard" conditioned formatting I only get the backgroud coloured.
A similar questions is this: How can I change color of text in a cell of MS Excel?
But the difference is that I (actually) don't work with programming. That means that I need a more simple or easy solution to implement this in my excel file.
Is this possible? A solution with VBA would also be possible, I know how to implement them.
here example how you can achieve required results:
Sub test()
Dim cl As Range
Dim sVar1$, sVar2$, pos%
sVar1 = "WUG-FGT"
sVar2 = "INZL-DRE"
For Each cl In Selection
If cl.Value2 Like "*" & sVar1 & "*" Then
pos = InStr(1, cl.Value2, sVar1, vbTextCompare)
cl.Characters(pos, Len(sVar1)).Font.Color = vbRed
End If
If cl.Value2 Like "*" & sVar2 & "*" Then
pos = InStr(1, cl.Value2, sVar2, vbTextCompare)
cl.Characters(pos, Len(sVar2)).Font.Color = vbGreen
End If
Next cl
End Sub
test
UPDATE
Is it possible to count how often the word has been detected. Either to write to total amount to a defined cell or what also would be great, to add the number of counts in brackets behind the word with an control variable? So in your example: A2: "WUG-FGT(1)", A4: "WUG-FGT(2)", A5: "WUG-FGT(3)"
Yes, but you should update the cell before colorizing, otherwise whole cell font will be colorized by the first char's color (e.g. cell contains both keywords and first is red, and second is green, after update whole cell font will be red). See updated code and test bellow:
Sub test_upd()
Dim cl As Range, sVar1$, sVar2$, pos%, cnt1%, cnt2%
Dim bVar1 As Boolean, bVar2 As Boolean
sVar1 = "WUG-FGT": cnt1 = 0
sVar2 = "INZL-DRE": cnt2 = 0
For Each cl In Selection
'string value should be updated before colorize
If cl.Value2 Like "*" & sVar1 & "*" Then
bVar1 = True
cnt1 = cnt1 + 1
cl.Value2 = Replace(cl.Value, sVar1, sVar1 & "(" & cnt1 & ")")
End If
If cl.Value2 Like "*" & sVar2 & "*" Then
bVar2 = True
cnt2 = cnt2 + 1
cl.Value2 = Replace(cl.Value, sVar2, sVar2 & "(" & cnt2 & ")")
End If
pos = InStr(1, cl.Value2, sVar1, vbTextCompare)
If bVar1 Then cl.Characters(pos, Len(sVar1)).Font.Color = vbRed
pos = InStr(1, cl.Value2, sVar2, vbTextCompare)
If bVar2 Then cl.Characters(pos, Len(sVar2)).Font.Color = vbGreen
bVar1 = False: bVar2 = False
Next cl
End Sub
test
Change Format of Parts of Values in Cells
Links
Workbook Download
Image
The Code
'*******************************************************************************
Sub CFF(Range As Range, SearchString As String, _
Optional ColorIndex As Long = -4105, _
Optional OccurrenceFirst0All1 As Long = 1, _
Optional Case1In0Sensitive As Long = 1)
' ColorIndex
' 3 for Red
' 10 for Green
' OccurrenceFirst0All1
' 0 - Only First Occurrence of SearchString in cell of Range.
' 1 (Default) - All occurrences of SearchString in cell of Range.
' Case1In0Sensitive
' 0 - Case-sensitive i.e. aaa <> AaA <> AAA
' 1 (Default) - Case-INsensitive i.e. aaa = AaA = AAA
Const cBold As Boolean = False ' Enable Bold (True) for ColorIndex <> -4105
Dim i As Long ' Row Counter
Dim j As Long ' Column Counter
Dim rngCell As Range ' Current Cell Range
Dim lngStart As Long ' Current Start Position
Dim lngChars As Long ' Number of characters (Length) of SearchString
' Assign Length of SearchString to variable.
lngChars = Len(SearchString)
' In Range.
With Range
' Loop through rows of Range.
For i = .Row To .Row + .Rows.Count - 1
' Loop through columns of Range.
For j = .Column To .Column + .Columns.Count - 1
' Assign current cell range to variable.
Set rngCell = .Cells(i, j)
' Calculate the position of the first occurrence
' of SearchString in value of current cell range.
lngStart = InStr(1, rngCell, SearchString, Case1In0Sensitive)
If lngStart > 0 Then ' SearchString IS found.
If OccurrenceFirst0All1 = 0 Then ' FIRST occurrence only.
GoSub ChangeFontFormat
Else ' ALL occurrences.
Do
GoSub ChangeFontFormat
lngStart = lngStart + lngChars
lngStart = InStr(lngStart, rngCell, SearchString, _
Case1In0Sensitive)
Loop Until lngStart = 0
End If
'Else ' SearchString NOT found.
End If
Next
Next
End With
Exit Sub
ChangeFontFormat:
' Font Formatting Options
With rngCell.Characters(lngStart, lngChars).Font
' Change font color.
.ColorIndex = ColorIndex
' Enable Bold for ColorIndex <> -4105
If cBold Then
If .ColorIndex = -4105 Then ' -4105 = xlAutomatic
.Bold = False
Else
.Bold = True
End If
End If
End With
Return
End Sub
'*******************************************************************************
Real Used Range (RUR)
'*******************************************************************************
' Purpose: Returns the Real Used Range of a worksheet.
' Returns: Range Object or "Nothing".
'*******************************************************************************
Function RUR(Optional NotActiveSheet As Worksheet) As Range
Dim objWs As Worksheet
If Not NotActiveSheet Is Nothing Then
Set objWs = NotActiveSheet
Else
Set objWs = ActiveSheet
End If
If objWs Is Nothing Then Exit Function
Dim HLP As Range ' Cells Range
Dim FUR As Long ' First Used Row Number
Dim FUC As Long ' First Used Column Number
Dim LUR As Long ' Last Used Row Number
Dim LUC As Long ' Last Used Column Number
With objWs.Cells
Set HLP = .Cells(.Cells.Count)
Set RUR = .Find("*", HLP, xlFormulas, xlWhole, xlByRows)
If Not RUR Is Nothing Then
FUR = RUR.Row
FUC = .Find("*", HLP, , , xlByColumns).Column
LUR = .Find("*", , , , xlByRows, xlPrevious).Row
LUC = .Find("*", , , , xlByColumns, xlPrevious).Column
Set RUR = .Cells(FUR, FUC) _
.Resize(LUR - FUR + 1, LUC - FUC + 1)
End If
End With
End Function
'*******************************************************************************
Usage
The following code if used with the Change1Reset0 argument set to 1, will change the format in each occurrence of the desired strings in a case-INsensitive search.
'*******************************************************************************
Sub ChangeStringFormat(Optional Change1Reset0 As Long = 0)
Const cSheet As Variant = "Sheet1"
Const cStringList As String = "WUG-FGT,INZL-DRE"
Const cColorIndexList As String = "3,10" ' 3-Red, 10-Green
' Note: More strings can be added to cStringList but then there have to be
' added more ColorIndex values to cColorIndexList i.e. the number of
' elements in cStringList has to be equal to the number of elements
' in cColorIndexList.
Dim rng As Range ' Range
Dim vntS As Variant ' String Array
Dim vntC As Variant ' Color IndexArray
Dim i As Long ' Array Elements Counter
Set rng = RUR(ThisWorkbook.Worksheets(cSheet))
If Not rng Is Nothing Then
vntS = Split(cStringList, ",")
If Change1Reset0 = 1 Then
vntC = Split(cColorIndexList, ",")
' Loop through elements of String (ColorIndex) Array
For i = 0 To UBound(vntS)
' Change Font Format.
CFF rng, CStr(Trim(vntS(i))), CLng(Trim(vntC(i)))
Next
Else
For i = 0 To UBound(vntS)
' Reset Font Format.
CFF rng, CStr(Trim(vntS(i)))
Next
End If
End If
End Sub
'*******************************************************************************
The previous codes should all be in a standard module e.g. Module1.
CommandButtons
The following code should be in the sheet window where the commandbuttons are created, e.g. Sheet1.
Option Explicit
Private Sub cmdChange_Click()
ChangeStringFormat 1
End Sub
Private Sub cmdReset_Click()
ChangeStringFormat ' or ChangeStringFormat 0
End Sub
Try:
Option Explicit
Sub test()
Dim rng As Range, cell As Range
Dim StartPosWUG As Long, StartPosINL As Long
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .UsedRange
For Each cell In rng
StartPosWUG = InStr(1, cell, "WUG-FGT")
StartPosINL = InStr(1, cell, "INZL-DRE")
If StartPosWUG > 0 Then
With cell.Characters(Start:=StartPosWUG, Length:=Len("WUG-FGT")).Font
.Color = vbRed
End With
End If
If StartPosINL > 0 Then
With cell.Characters(Start:=StartPosINL, Length:=Len("INZL-DRE")).Font
.Color = vbGreen
End With
End If
Next
End With
End Sub
basically I need to split a cell that has a few values, seperated by a comma into more cells. Then i need to create the exact amount of the cells under the new cells to be able to transpose this range later to have a new table.
In the picture you can see an example of what I have and what I need. I needed to anonymyze the data. Also I have hundreds of rows that need to changed like the 2 in the example.
Ths is my current code:
Sub texttocolumns()
Dim rng As Range
Dim x As Integer
x = ActiveSheet.UsedRange.Rows.Count
For i = x - 2 To 1
Cells(2 + i, 8).texttocolumns _
Destination:=Cells(2 + i, 9), _
Comma:=True
k = Application.WorksheetFunction.CountA("A" & "2 + i"" & "":" & "AT1")
Cells(2 + i, 1).Rows(k).Insert
Next i
End Sub
I can't find my mistake at the moment, could someone please help me out? thanks!
Since the output result is posted to a different location the expensive task of inserting rows can be avoided.
Try this procedure, which also avoids working with the source range by generating from it two Arrays:
An array containing the fixed fields
An array containing the field that needs to be split
The Procedure:
Sub Range_Split_A_Field()
Dim wsTrg As Worksheet, rgOutput As Range
Dim aFld_1To5 As Variant, aFld_6 As Variant
Dim aFld As Variant
Dim lRow As Long, L As Long
lRow = 3
Set wsTrg = ThisWorkbook.Sheets("Sht(2)")
Application.Goto wsTrg.Cells(1), 1
With wsTrg.Cells(lRow, 1).CurrentRegion
Set rgOutput = .Rows(1).Offset(0, 10)
.Rows(1).Copy
rgOutput.PasteSpecial
Application.CutCopyMode = False
aFld_1To5 = .Offset(1, 0).Resize(-1 + .Rows.Count, 5).Value2
aFld_6 = .Offset(1, 5).Resize(-1 + .Rows.Count, 1).Value2
End With
lRow = 1
For L = 1 To UBound(aFld_1To5)
aFld = aFld_6(L, 1)
If aFld = vbNullString Then
rgOutput.Offset(lRow).Resize(1, 5).Value = WorksheetFunction.Index(aFld_1To5, L, 0)
rgOutput.Offset(lRow, 5).Resize(1, 1).Value = aFld
lRow = 1 + lRow
Else
aFld = Split(aFld, Chr(44))
aFld = WorksheetFunction.Transpose(aFld)
rgOutput.Offset(lRow).Resize(UBound(aFld), 5).Value = WorksheetFunction.Index(aFld_1To5, L, 0)
rgOutput.Offset(lRow, 5).Resize(UBound(aFld), 1).Value = aFld
lRow = lRow + UBound(aFld)
End If: Next
End Sub
Please see the following pages for a better understanding of the resources used:
Application.Goto Method (Excel)
With Statement
Range Object (Excel)
Chr Function
UBound Function
WorksheetFunction Object (Excel)
Would something like this work:
'A1 = A,B,C,D,E,F,G
'A2 = 1,2,3,4,5,6,7
'A3 = A!B!C!D!E!F!G
'Test procedure will result in:
'A - G in cells A1:A7
'1,2,3,4,5,6,7 in cell A8.
'A - G in cells A9:A15
Sub Test()
TextToColumns Sheet1.Range("A1")
TextToColumns Sheet1.Range("A9"), "!"
End Sub
Public Sub TextToColumns(Target As Range, Optional Delimiter As String = ",")
Dim rng As Range
Dim lCount As Long
Dim x As Long
'How many delimiters in target string?
lCount = Len(Target) - Len(Replace(Target, Delimiter, ""))
'Add the blank rows.
For x = 1 To lCount + 1
Target.Offset(1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next x
'Split the string.
Target.TextToColumns Target, xlDelimited, xlTextQualifierNone, , , , , , True, Delimiter
'Use TRANSPOSE formula to paste to rows and then remove formula.
With Target.Offset(1).Resize(lCount + 1, 1)
.FormulaArray = "=TRANSPOSE(R" & Target.Row & "C:R" & Target.Row & "C" & lCount + 1 & ")"
.Value = .Value
End With
'Delete the original text string.
Target.EntireRow.Delete
End Sub
Edit:
To use from the Macro dialog box you could add this small procedure:
Public Sub Test()
Dim y As Long
y = ActiveSheet.UsedRange.Rows.Count
With ActiveSheet
For y = 5 To 1 Step -1
TextToColumns .Cells(y, 1)
Next y
End With
End Sub
Note: ActiveSheet.UsedRange.Rows.Count is a terrible way to find the last row.
See this thread: Error in finding last used cell in VBA