I´m trying to add a semicolon before the last character in a column (A:A).
I want to change the value in specific cells from e.g. GLA-12342 to GLA-1234;2
This should only be done on cells that contains the following text:
GLA, GLX, GLV, GLY, GLC
Are there some nice VBA-guru out there who could help me with this
What I got sofar is this...
Sub Semikolon()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("A:A")
For Each cel In SrchRng
If InStr(1, cel.Value, "GLA") > 0 Then
' Can not figure out how to solve this...
End If
Next cel
End Sub
You almost got it. Just use Left$ and Right$ functions to split the string on the correct place.
Also I recommend to limit the SrchRng to the used cells only to speed it up.
Option Explicit
Sub Semikolon()
Dim SrchRng As Range
Set SrchRng = Range("A1", Cells(Rows.Count, "A").End(xlUp))
Dim Cel As Range
For Each Cel In SrchRng
If InStr(1, Cel.Value, "GLA") > 0 Or _
InStr(1, Cel.Value, "GLX") > 0 Then 'add more or statements here
Cel.Value = Left$(Cel.Value, Len(Cel.Value) - 1) & ";" & Right$(Cel.Value, 1)
End If
Next Cel
End Sub
Related
I have a table that is filled with formulas tied to another sheet. These formulas grab data from the other table based on whether the date at the top of the column matches the date in a single cell (Week Ending Date). I want to be able to automatically copy only the cells with a value greater than 0, and then paste them back into the same cell as a value. I used the following formula to try and accomplish this, but it didn't quite do what I wanted it to. Be gentle, I'm a novice at best.
Sub CopyC()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("Table4")
For Each cel In SrchRng
If cel.Value > 0 Then
cel.Copy
cel.PasteSpecial xlPasteValues
End If
Next cel
End Sub
Expected Output: Copy only Cells in my table that are greater than 0 and paste as value.
Goal: Preserve Formulas in cells that are blank
Results from above: Very slowly progressed cell by cell and copied and pasted in all cells, including blanks and 0 values, until it was stopped
Give this a try:
Sub CopyC()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("Table4")
For Each cel In SrchRng
If IsNumeric(cel.Value) And cel.Value > 0 Then
cel.Value = cel.Value
End If
Next cel
End Sub
EDIT: add an alternative using an array to loop through the data, this should be a bit faster:
Sub CopyC()
Dim SrchRng As Range: Set SrchRng = Range("Table4")
Dim arrSearch As Variant: arrSearch = SrchRng
Dim fRow As Long: fRow = SrchRng.Cells(1, 1).Row - 1
Dim fCol As Long: fCol = SrchRng.Cells(1, 1).Column - 1
Dim R As Long, C As Long
For R = LBound(arrSearch) To UBound(arrSearch)
For C = LBound(arrSearch, 2) To UBound(arrSearch, 2)
If IsNumeric(arrSearch(R, C)) And arrSearch(R, C) > 0 Then Cells(R + fRow, C + fCol).Value = arrSearch(R, C)
Next C
Next R
End Sub
Hope you can help.
I have column A and B
In A, I need to replace all text containing "Forsikringspræmie" with "" (Blank)
This code works. Sub KSV_Remove_Forsikringspræmie()
But in Column B, I need the Opposit, to happen.
And the code Sub KSV_Remove_Not_Forsikringspræmie() dosent work.
Sub KSV_Remove_Forsikringspræmie()
Dim KSV_SrchRng As Range, cel As Range
Set KSV_SrchRng = Range("A1:A99")
For Each cel In KSV_SrchRng
If InStr(1, cel.Value, "Forsikringspræmie") > 0 Then
cel.Value = ""
End If
Next cel
End Sub
Sub KSV_Remove_Not_Forsikringspræmie()
Dim KSV_SrchRng As Range, cel As Range
Set KSV_SrchRng = Range("B1:B99")
For Each cel In KSV_SrchRng
If InStr(1, cel.Value, Not "Forsikringspræmie") Then
cel.Value = ""
End If
Next cel
End Sub
I think you may just be placing the Not in the wrong place. Try this:
Sub KSV_Remove_Not_Forsikringspræmie()
Dim KSV_SrchRng As Range, cel As Range
Set KSV_SrchRng = Range("B1:B99")
For Each cel In KSV_SrchRng
If Not (InStr(1, cel.Value, "Forsikringspræmie")) Then
cel.Value = ""
End If
Next cel
End Sub
In response to your comment to Greg's post (comment reads: with one little error it now deletes every cell, since the cells containing "Forsikringspræmie" they are numberede eg. "Forsikringspræmie1, Forsikringspræmie2" etc.... and a wild card dosent work.)... if you want to replace and keep the numbers that were in the cell, try the Replace function, such that:
With Columns(1)
.Replace what:="Forsikringspræmie", replacement:="", searchorder:=xlByColumns, MatchCase:=False
End With
Would like to have a column range searched for specific text ("REASON") and when found, have that entire cell content be filled onto a range of different cells.
This is done until a new "REASON" is found - in which case this cell content will be copied accordingly like before.
This is before result:
before
... and expected result, with filled text in J column
Thanks guys, been messing with this but not sure where to go from here:
Sub AddSus()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("g1:g60")
For Each cel In SrchRng
If InStr(1, cel.Value, "REASON") > 0 Then
cel.Offset(1, 0).Value = cel.Value
End If
Next cel
End Sub
There's a few things wrong with this. As you iterate through cel in SrchRng your conditional is checking the value of that cel to contain "REASON". This is not what you want. What you are essentially doing is checking for the "REASON" string and saying all entries below this, until the next reason, should be true for a conditional to populate column J.
Lets, really briefly, run through the logic of a single cell to illustrate why your code was not doing what you wanted:
In cell G3, you check to see if it contains the "REASON" string. It does not, so there is no assignment of any value anywhere. The following will do what you want:
Sub AddSus()
Dim SrchRng As Range, cel As Range, reasonString As String
Set SrchRng = Range("g1:g60")
For Each cel In SrchRng
If InStr(1, cel.Value, "REASON") > 0 Then
reasonString = cel.Value
ElseIf cel.Value <> "" Then
cel.Offset(0, 3).Value = reasonString
End If
Next cel
End Sub
Minor note but if you are in column G and you want to populate column J, the offset should be .offSet(0,3).
Use FIND to quickly jump between instances of REASON:
Sub AddSus()
Dim SrchRng As Range
Dim rFound As Range
Dim lStart As Long, lEnd As Long
Dim sFirstAddress As String
Dim sReason As String
Set SrchRng = ThisWorkbook.Worksheets("Sheet1").Range("G:G")
'Find the first instance of REASON in column G.
Set rFound = SrchRng.Find(What:="REASON:", _
After:=SrchRng.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True)
'Check something has been found before continuing.
If Not rFound Is Nothing Then
'Find just keeps looping unless you tell it to stop,
'so record the first found address.
sFirstAddress = rFound.Address
Do
'Save the reason and start row.
sReason = rFound.Value
lStart = rFound.Row
'Find the next REASON in column G.
Set rFound = SrchRng.FindNext(rFound)
If rFound.Address = sFirstAddress Then
'The first instance has been found again, so use column I to find last row of data.
lEnd = SrchRng.Offset(, 2).Cells(Rows.Count, 1).End(xlUp).Row
Else
lEnd = rFound.Row
End If
'Fill in from 2 rows down from Start and 2 rows up from End.
'This will go wrong if there's not enough space between REASONs.
With ThisWorkbook.Worksheets("Sheet1")
.Range(.Cells(lStart + 2, 10), .Cells(lEnd - 2, 10)) = sReason
End With
Loop While rFound.Address <> sFirstAddress
End If
End Sub
A Quick and Dirty Solution...
Sub AddSus()
Dim SrchRng As Range, cel As Range
Dim reason As String
Set SrchRng = Range("g1:g60")
For Each cel In SrchRng
If InStr(1, cel.Value, "REASON") > 0 Then
reason = cel.Value
End If
If cel.Column = 10 And Len(cel.Offset(,-1)) > 0 Then
cel.Value = reason
End If
Next
End Sub
I'm trying to create a VBA Macro that would search for a non-blank cell in "Sheet1" and if non-blank, it would paste the respective active cell column from "Sheet1" to the same column in "Sheet2".
Below is my code, but I'm sure I'm doing something wrong, because the code is throwing me an error : 1004.
Sub Test()
Dim cel As Range
Dim strAddress As String
Dim StartPoint As Range
Set StartPoint = ActiveCell
'Change to necessary amount of Rows & Columns
With Sheets("Sheet1").Range(Cells(9, 5), Cells(1000, 200))
Set cel = .Find(What:="*", After:=Cells(1000, 200), SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not cel Is Nothing Then
strAddress = cel.Address
Do
' Do something with cel, e.g.
StartPoint.EntireColumn.Copy Destination:=Worksheets("Sheet2").Range(StartPoint.Column & "1").End(xlToRight).Offset(1)
Set cel = .FindNext(After:=cel)
If cel Is Nothing Then Exit Do
Loop Until cel.Address = strAddress
End If
End With
End Sub
Can someone kindly advise what I'm doing wrong?
Thank you!
Try these two modifications:
With Sheets("Sheet1").Range("E9:GR1000")
.
cel.EntireColumn.Copy Worksheets("Sheet2").Columns(cel.Column)
I just started teaching myself VBA so thanks in advance. Why is this giving me an error? The code searches for the column of dates that are in the future. Then searches in that column for any cells that have a value and colors them yellow.
Thanks!
Sub Macro1()
Dim cell As Range
Dim cell2 As Range
Dim ColumnN As Long
For Each cell In Range("I2:ZZ2")
If cell.Value > Now() Then
'
ColumnN = cell.Column
ColumnL = ConvertToLetter(ColumnN)
MsgBox ColumnL & cell.Row
For Each cell2 In Range("ColumnL:ColumnL")
If Not cell2 Is Empty Then
cell2.Interior.ColorIndex = 6
End If
Next cell2
End If
End Sub()
Function ConvertToLetter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
ConvertToLetter = vArr(0)
End Function
You were almost there!
There's two main problems to fix:
replace:
For Each cell2 In Range("ColumnL:ColumnL")
with
For Each cell2 In Range(ColumnL & ":" & ColumnL)
and
If Not cell2 Is Empty Then
with
If Not IsEmpty(cell2) Then
This should result in the following:
Sub Macro1()
Dim cell As Range
Dim cell2 As Range
Dim ColumnN As Long
Dim ColumnL As String
For Each cell In Range("I2:ZZ2")
If cell.Value > Now() Then
ColumnN = cell.Column
ColumnL = ConvertToLetter(ColumnN)
MsgBox ColumnL & cell.Row
For Each cell2 In Range(ColumnL & ":" & ColumnL)
If Not IsEmpty(cell2) Then
cell2.Interior.ColorIndex = 6
End If
Next cell2
End If
Next cell
End Sub
Function ConvertToLetter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
ConvertToLetter = vArr(0)
End Function
Although it is a little inefficient it gets the job done!
To check if a cell is empty, you need to switch the order of how that's done. Switch your If Not statement to If Not IsEmpty(cell2) Then.
Also, it is highly recommended not to name your variables cell, because this is a close to some "special words" (I forget the technical term) Excel uses. I always just use cel instead.
Sub test()
Dim cel As Range
Dim cel2 As Range
Dim ColumnN As Long
For Each cel In Range("I2:ZZ2")
If cel.Value > Now() Then
ColumnN = cel.Column
' ColumnL = ConvertToLetter(ColumnN)
' MsgBox ColumnL & cell.Row
If Not IsEmpty(cel) Then
cel.Interior.ColorIndex = 6
End If
End If
Next cel
End Sub
Edit: If you notice, I also tweaked your cell2 range. This removed the need to run another macro (which can be a cause of issues sometimes), so you only need the column Number.
Edit2: I removed the "ColumnL" range selection - what is that for? I can add it back in, but wasn't sure why you'd loop through I:ZZ columns, but only have the highlighting in column N.
Edit2:
I tweaked the code, now it's much shorter and should run a bit faster:
Sub Macro2()
Dim cel As Range, rng As Range
Dim lastCol As Long
Application.ScreenUpdating = False
lastCol = Cells(2, 9).End(xlToRight).Column ' Note, this assumes there are NO gaps in the columns from I:ZZ
'lastCol = cells(2,16384).End(xltoleft).column ' use this instead, if there are gaps in I2:ZZ2
Set rng = Range(Cells(2, 9), Cells(2, lastCol))
For Each cel In rng
If cel.Value > Now() Then
cel.Interior.ColorIndex = 6
End If
Next cel
Application.ScreenUpdating = True
End Sub