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
Related
I'm trying to count the number of instances of a cell containing all uppercase characters in a user defined range, I've got some code already which loops through and highlights those uppercase cells correctly, but I'm struggling to apply that logic to VBA's Countif function. Here's the code I've got but its giving a mismatch error:
'count instances of all caps
Dim allcaps As Long
allcaps = Application.CountIf(Range(rngCompany.Cells(1, 1), rngCompany.Cells(Lastrow, 1)), UCase(Range(rngCompany.Cells(1, 1), rngCompany.Cells(Lastrow, 1))))
MsgBox "There are " & allcaps & " uppercase company names to review."
The code which is highlighting the cells correctly is:
'Highlight all caps company names for review
With ws
For i = 2 To Lastrow
' checks if cells in company name col are uppercase
If rngCompany.EntireColumn.Cells(i, 1).Value = UCase(rngCompany.EntireColumn.Cells(i, 1).Value) Then
wbk1.Sheets(1).Rows(i).Interior.ColorIndex = 6 '6: Yellow
Else
End If
Next i
End With
Is there a way to make the countif code work in a similar way within the loop? Thanks.
Here is how you can do it:
Function AllCapsCount(Target As Range) As Long
With Target.Parent
AllCapsCount = .Evaluate("=SUMPRODUCT(--EXACT(" & Target.Address & ",UPPER(" & Target.Address & ")))")
End With
End Function
Tim's suggestion of simply adding a counter within the loop was the simplest solution for me, after a long day I'd overlooked that way forward!
Code example for anyone coming across this in future:
AllCapsCount = 0
With ws
For i = 2 To Lastrow
' checks if cells in company name col are uppercase
If rngCompany.EntireColumn.Cells(i, 1).Value = UCase(rngCompany.EntireColumn.Cells(i, 1).Value) Then
wbk1.Sheets(1).Rows(i).Interior.ColorIndex = 6 '6: Yellow
AllCapsCount = AllCapsCount + 1
Else
End If
Next i
End With
Highlight and Count Cells if UCase but no LCase
Sub TESTgetAllCapsRange()
Dim rngCompany As Range
Set rngCompany = Range("A2:E11")
rngCompany.Interior.Color = xlNone
Dim rng As Range: Set rng = getAllCapsRange(rngCompany)
If Not rng Is Nothing Then
rng.Interior.Color = vbYellow
Dim AllCaps As Long: AllCaps = rng.Cells.CountLarge
If AllCaps > 1 Then
MsgBox "There are " & AllCaps _
& " uppercase company names to review."
Else
MsgBox "There is 1 uppercase company name to review."
End If
Else
MsgBox "There are no uppercase company names to review."
End If
End Sub
Function getAllCapsRange(rng As Range) As Range
If Not rng Is Nothing Then
Dim tRng As Range
Dim aRng As Range
Dim cel As Range
For Each aRng In rng.Areas
For Each cel In aRng.Cells
If Not IsError(cel) Then
If containsUCaseButNoLCase(cel.Value) Then
buildRange tRng, cel
End If
End If
Next cel
Next aRng
If Not tRng Is Nothing Then
Set getAllCapsRange = tRng
End If
End If
End Function
Function containsUCaseButNoLCase(ByVal CheckString As String) As Boolean
' Check if there is an upper case character.
If StrComp(CheckString, LCase(CheckString), vbBinaryCompare) <> 0 Then
' Check if there are no lower case characters.
If StrComp(CheckString, UCase(CheckString), vbBinaryCompare) = 0 Then
containsUCaseButNoLCase = True
End If
End If
End Function
Sub buildRange(ByRef BuiltRange As Range, AddRange As Range)
If Not AddRange Is Nothing Then
If Not BuiltRange Is Nothing Then
Set BuiltRange = Union(BuiltRange, AddRange)
Else
Set BuiltRange = AddRange
End If
End If
End Sub
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 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
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 have a spreadsheet that is generated as a report in our Enterprise system and downloaded into an Excel spreadsheet. Blank cells in the resulting spreadsheet are not really blank, even though no data is present - and the blank cells do Not contain a 'space' character.
For example, the following cell formula in A2 returns TRUE (if A1 is a blank cell):
=IF(A1="","TRUE","FALSE")
However,
=ISBLANK(A1)
returns FALSE.
You can replicate this problem by typing an apostrophe (') in a cell and copying the cell. Then, use Paste Special...Values to paste to another cell and the apostrophe is not visible in the pasted cell, nor in the Formula Bar. There appears to be a clear cell, but it will evaluate to FALSE using ISBLANK.
This causes sorting to result in the fake blank cells at the top of an ascending sort, when they need to be at the bottom of the sort.
I can use a vba loop to fix the fake blanks, to loop through every column and evaluate
IF Cell.VALUE = "" Then
Cell.Clear
but because the spreadsheet has tens of thousands of rows of data and as many as 50 columns, this adds substantial overhead to the program and I would prefer to use FIND and Replace.
Here is the code that does not currently work:
Range("ZZ1").Copy
Range("Table1[#All]").Select
With Selection
.Replace What:="", Replacement:=.PasteSpecial(xlPasteValues, xlNone, False, False), _
LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End With
The following things do not work to clear the fake blank cells either:
Replacement:= vbnullstring
Replacement:= ""
Replacement:= Cells.Clear
Replacement:= Cells.ClearContents
Replacement:= Cells.Value = ""
I have tried 20 other things that do not work either.
Try this
With ActiveSheet.UsedRange
.NumberFormat = "General"
.Value = .Value
End With
A variant array provides an efficient way of handling the false empties:
Sub CullEm()
Dim lngRow As Long
Dim lngCol As Long
Dim X
X = ActiveSheet.UsedRange.Value2
For lngRow = 1 To UBound(X, 1)
For lngCol = 1 To UBound(X, 2)
If Len(X(lngRow, lngCol)) = 0 Then X(lngRow, lngCol) = vbNullString
Next
Next
ActiveSheet.UsedRange.Value2 = X
End Sub
The problem is that you are searching for a hidden .PrefixCharacter which are not covered by the standard replacement function. For more information on this you might want to visit MSDN: https://msdn.microsoft.com/en-us/library/office/ff194949.aspx
In order to find and replace these you'll have to use the .Find function because it can look at the formulas (rather than only at a cell's value). Here is a short sample code to illustrate that:
Option Explicit
Public Sub tmpTest()
Dim cell As Range
Dim rngTest As Range
Dim strFirstAddress As String
Set rngTest = ThisWorkbook.Worksheets(1).Range("A1:G7")
Set cell = rngTest.Find("", LookIn:=xlFormulas, lookat:=xlPart)
If Not cell Is Nothing Then
strFirstAddress = cell.Address
Do
cell.Value = vbNullString
Set cell = rngTest.FindNext(cell)
Loop While strFirstAddress <> cell.Address And Not cell Is Nothing
End If
End Sub
I can't figure out anything that you could put in Replacement to get that to work. I'm afraid you're stuck looping. You can reduce the overhead by using .Find instead of looping through every cell.
Sub ClearBlanks()
Dim rng As Range
Dim rFound As Range
Dim sFirstAdd As String
Dim rFoundAll As Range
Set rng = Sheet1.UsedRange
Set rFound = rng.Find(vbNullString, , xlValues, xlWhole)
If Not rFound Is Nothing Then
sFirstAdd = rFound.Address
Do
If rFoundAll Is Nothing Then
Set rFoundAll = rFound
Else
Set rFoundAll = Application.Union(rFound, rFoundAll)
End If
Set rFound = rng.FindNext(rFound)
Loop Until rFound.Address = sFirstAdd
End If
If Not rFoundAll Is Nothing Then
rFoundAll.ClearContents
End If
End Sub
You can use the table filter to select the (seemingly) blank cells in each column and clear the contents. This should be quicker than finding each blank cell.
Sub clearBlankTableEntries()
Dim tbl As ListObject, c As Byte
Set tbl = ActiveSheet.ListObjects("testTable")
For c = 1 To tbl.Range.Columns.Count
tbl.Range.AutoFilter Field:=c, Criteria1:="="
Range(tbl.Name & "[Column" & c & "]").ClearContents
tbl.Range.AutoFilter Field:=c
Next c
End Sub