Related
I just want to check if there are empty rows in a range, for instance, if S28 is either "KO" or "OK", the line above (offset(-1,0) should not be blank.
If it is blank the function should stop.
If a cell is blank and the cell above is blank, that is ok.
Each cell in S has a formula, countif function.
The code says that there are empty rows, which is not the case. I removed the data in S28, which you can see on the picture. Hence, there should be no msgbox. The first line check is in S12.
Private Function detecht_empty_rows() As Boolean
Call DefineVariables
Dim lrowS As Long
Dim cell As Range
Dim startingcell As String
lrowS = shInput.cells(Rows.Count, 19).End(xlUp).Row
For Each cell In shInput.Range("S13" & ":" & "S" & lrowS)
startingcell = cell.Address
If cell.Text = "" And IsEmpty(cell.Offset(-1, 0)) = True Then
ElseIf cell.Text = "OK" Or cell.Text = "KO" And IsEmpty(cell.Offset(-1, 0)) = True Then
MsgBox "Please remove the blank rows"
Exit Function
End If
Next cell
End Function
Please, test the next adapted function. I assume that DefineVariables defines the shInput worksheet. My code, for testing reasons, defines the sheet in discussion as the active one. You can delete/comment the declaration and the value allocation:
Private Function detecht_empty_rows() As Boolean
'Call DefineVariables
Dim lrowS As Long, cell As Range, startingcell As String
Dim shInput As Worksheet, boolEmpty As Boolean, rowNo As Long
Set shInput = ActiveSheet 'use here your defined worksheet.
'Clear the declaration if declared at the module level
lrowS = shInput.cells(rows.count, 19).End(xlUp).row
'new inserted code line:________________________________
lrowS = lastR(shInput.range("S13" & ":" & "S" & lrowS))
'_______________________________________________________
For Each cell In shInput.Range("S13" & ":" & "S" & lrowS)
If cell.text = "" And cell.Offset(-1, 0) = "" Then
boolEmpty = True: rowNo = cell.Offset(-1).row: Exit For
ElseIf (cell.text = "OK" Or cell.text = "KO") And cell.Offset(-1, 0) = "" Then
boolEmpty = True: rowNo = cell.Offset(-1).row: Exit For
End If
Next cell
If boolEmpty Then MsgBox "Please remove the blank row (" & rowNo & ").": detecht_empty_rows = False: Exit Function
detect_empty_rows = True
End Function
The next function will calculate the last row to be processed in a different way:
Function lastR(rng As range) As Long
Dim i As Long, lngStart As Long, lngEnd As Long, sh As Worksheet
lngStart = rng.cells(1).Row: lngEnd = lngStart + rng.Rows.Count - 1
Set sh = rng.Parent
For i = lngStart To lngEnd
If WorksheetFunction.CountIf(sh.range(sh.range("S" & i), sh.range("S" & lngEnd)), "OK") + _
WorksheetFunction.CountIf(sh.range(sh.range("S" & i), sh.range("S" & lngEnd)), "KO") = 0 Then
lastR = i - 1: Exit Function
End If
Next i
End Function
You must change
ElseIf cell.text = "OK" Or cell.text = "KO" And IsEmpty(cell.Offset(-1, 0))
with
ElseIf (cell.text = "OK" Or cell.text = "KO") And cell.Offset(-1, 0) = ""
The Or conditions must be checked like a single check toghether with IsEmpty part.
Then, startingcell = cell.Address is useless and unused, it takes a new value for each iteration.
Not necessarily to use IsEmpty(cell.Offset(-1, 0)) = True. It is enough to use IsEmpty(cell.Offset(-1, 0)).The method returns a Boolean variable, anyhow.
Being a function returning a Boolean, it should return it. It can be used in the code calling the function.
But in case of a formula, even if it returns a null string (""), IsEmpty cannot be used. I mean, it does not work, the cell no being empty. The code must use cell.Offset(-1, 0) = "".
Please, take care to not have an empty cell at "S12"...
I have tried this code which works fine for a cell that only contain number:
Sub IncreaseCellValue()
'Add 1 to the existing cell value
Range("A1").Value = Range("A1") + 1
End Sub
How can I do something similar if the cell has text and a number. For example, I have "Apple 1" and I want to "increase" the cell text to "Apple 2" and next time I run the macro I want "Apple 3".
Here's another way you could solve this problem:
Sub IncreaseCellValue()
Dim value As Variant
'Add 1 to the existing cell value
If IsNumeric(Range("A1").value) Then
Range("A1").value = Range("A1") + 1
Else
value = Split(Range("A1").value, " ")
Range("A1").value = value(0) & " " & (CInt(value(1)) + 1)
End If
End Sub
It will cover the 2 cases you presented in your question but not every scenario you could throw at it.
Try using the following function
Sub IncreaseCellValue()
'Add 1 to the existing cell value
Range("A1").Value = Replace(Range("A1").Value2, CleanString(Range("A1")), vbNullString) & CInt(CleanString(Range("A1").Value2)) + 1
End Sub
Function CleanString(strIn As String) As String
Dim objRegex
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = "[^\d]+"
CleanString = .Replace(strIn, vbNullString)
End With
End Function
please check:
Option Explicit
Sub IncreaseCellValue()
'Add 1 to the existing cell value
Dim rg As Range
Set rg = Cells(Rows.Count, "A").End(xlUp)
Range("A1" & ":" & rg.Address).AutoFill Destination:=Range("A1" & ":" & rg.Offset(1, 0).Address), Type:=xlFillDefault
End Sub
Or you may try something like this...
Function GetNumber(ByVal rng As Range) As Long
Dim i As Long
For i = Len(rng.Value) To 1 Step -1
If IsNumeric(Mid(rng.Value, i, 1)) Then
GetNumber = GetNumber & Mid(rng.Value, i, 1)
Else
Exit For
End If
Next i
End Function
Sub IncrementNumber()
Dim num As Long
num = GetNumber(Range("A1"))
Range("A1").Value = Replace(Range("A1").Value, num, num + 1)
End Sub
First off thank you very much. Over the last few months (i believe) my coding has progressed drastically. Any and all criticize is always welcome (rip me apart).
Recently I started to try to use different Subs (I dont quite understand when to use functions etc, but i figure it is good structure practice for when i figure it out.
I am hitting a Run-time 424 Error with the following bit of code in Sub ownerCHECK
Sub OccupationNORMALIZATION()
Dim infoBX As String
' initialize variables
LRow = ActiveSheet.UsedRange.Rows.Count
LCol = ActiveSheet.UsedRange.Columns.Count
STATUScounter = LRow
Do While infoBX = ""
infoBX = InputBox("Enter Occupation Column", "Occupation Column")
Loop
restaurCHECK (infoBX)
Application.ScreenUpdating = True
Application.StatusBar = ""
End Sub
-
Sub restaurCHECK(infoBX As String)
Dim RestaurantS(), RestaurantDQs() As Variant
Dim i, LRow, LCol, STATUScounter As Long
Dim rRng As Range
LRow = ActiveSheet.UsedRange.Rows.Count
LCol = ActiveSheet.UsedRange.Columns.Count
STATUScounter = LRow
RestaurantS = Array("estaur", "food", "cafe", "beverage", "waiter", "waitr", _
"waitstaff", "wait staff", "grill") 'array list of target occupations
RestaurantDQs = Array("fast", "pub", "import", "packing", "processing", "packag", _
"retired", "anufact", "distrib") ' disqualifying words for Restaurante category
Set rRng = Range(infoBX & "2:" & infoBX & LRow)
Application.ScreenUpdating = False
For Each cell In rRng
ownerCHECK (cell)
For i = LBound(RestaurantS) To UBound(RestaurantS)
If InStrRev(cell.Value, UCase(RestaurantS(i))) > 0 Then
cell.Offset(, 1) = "Restaurants"
cell.Interior.Color = 52479
End If
Debug.Print cell.Value
Next
For i = LBound(RestaurantDQs) To UBound(RestaurantDQs)
If InStrRev(cell.Value, UCase(RestaurantDQs(i))) And cell.Interior.Color = 52479 Then
cell.Interior.Color = 255
cell.Offset(, 1) = ""
End If
Next
STATUScounter = STATUScounter - 1
Application.StatusBar = "REMAINING ROWS " & STATUScounter & " tristram "
Next cell
End Sub
-
Sub ownerCHECK(str_owner As Range)
Dim owner() As Variant
owner() = Array("owner", "shareholder", "owns ")
For i = LBound(owner) To UBound(owner)
If InStrRev(str_owner, UCase(owner(i))) > 0 Then
cell.Offset(, 2) = "Owner"
End If
Next
End Sub
I can see a couple of issues in ownerCHECK():
"cell" is not defined (unless it's global)
you shouldn't use "cell" as a variable name (internal VBA property)
check validity of incoming range
.
Option Explicit
Sub ownerCHECK(ByRef rngOwner As Range)
If Not rngOwner Is Nothing Then
Dim owner() As Variant
owner() = Array("OWNER", "SHAREHOLDER", "OWNS ")
For i = LBound(owner) To UBound(owner)
If InStrRev(UCase(rngOwner), owner(i)) > 0 Then
rngOwner.Offset(, 2) = "Owner"
End If
Next
End If
End Sub
I'm trying to concatenate a bunch of columns in Excel. I know I can manually do with:
=A1&", "&B1&", "&C1 (and so on)
but I have about 40 columns, and I'm looking for a way to streamline this process.
Thanks in advance for any help!
As a user function taking a range
Public Function ClarkeyCat(ByRef rng As Range) As Variant
Dim c As Range
Dim ans As Variant
For Each c In rng
If (c.Value <> "") Then
ans = IIf(ans = "", "", ans & ",") & c.Value
End If
Next
ClarkeyCat = ans
End Function
Changing the Variant types, if you need to (to string, most likely).
Use like this:
I would use vba for this. For each column you would want something like (assuming values are in row 1)
myString = ""
for i = 1 to 40
if i <> 40 then
myString = myString & Cells(1, i) & ", "
else:
myString = myString & Cells(1, i)
end if
next i
myString will then have the contents of your concatenated string.
Let me post my function too. I've run into this problem as well in the past.
My problem usually arise when I try to concatenate dates, errors and blank cells.
So I try to cover most of those using below:
Function CONCATPLUS(ref_value As Range, Optional delimiter As Variant) As String
Dim cel As Range
Dim refFormat As String, myvalue As String
If ref_value.Cells.Count = 1 Then CONCATPLUS = CVErr(xlErrNA): Exit Function
If IsMissing(delimiter) Then delimiter = " "
For Each cel In ref_value
refFormat = cel.NumberFormat
Select Case TypeName(cel.Value)
Case "Empty": myvalue = vbNullString
Case "Date": myvalue = Format(cel, refFormat)
Case "Double"
Select Case True
Case refFormat = "General": myvalue = cel
Case InStr(refFormat, "?/?") > 0: myvalue = cel.Text
Case Else: myvalue = Format(cel, refFormat)
End Select
Case "Error"
Select Case True
Case cel = CVErr(xlErrDiv0): myvalue = "#DIV/0!"
Case cel = CVErr(xlErrNA): myvalue = "#N/A"
Case cel = CVErr(xlErrName): myvalue = "#NAME?"
Case cel = CVErr(xlErrNull): myvalue = "#NULL!"
Case cel = CVErr(xlErrNum): myvalue = "#NUM!"
Case cel = CVErr(xlErrRef): myvalue = "#REF!"
Case cel = CVErr(xlErrValue): myvalue = "#VALUE!"
Case Else: myvalue = "#Error"
End Select
Case "Currency": myvalue = cel.Text
Case Else: myvalue = cel
End Select
If Len(myvalue) <> 0 Then
If CONCATPLUS = "" Then
CONCATPLUS = myvalue
Else
CONCATPLUS = CONCATPLUS & delimiter & myvalue
End If
End If
Next
End Function
As of now, I've not encountered a cell entry this function cannot concatenate.
Feel free to adjust to your needs or hearts content. HTH.
When concatenating a range single row or column you can do this in a single shot using Application.Transpose to avoid range loops
This UDF has three arguments
A 1D range (can be a column or row)
An optional delimiter (, is used if there is no entrey)
An optional entry to specify if the range is a row (enter TRUE for a range - which on further thought I will update the UDF to automatically detect whether the range is row OR column BASED)
Note that in terms of the other answers
IIF evaluates both the TRUE and FALSE arguments as VBA doesn't [short circuit](
http://en.wikipedia.org/wiki/Short-circuit_evaluation). So IFF can be expensive inside loops
when concatenating join the long string to the combined output of the short strings, rather than long with short, then long with short again
code
Function ConCat(rng1 As Range, Optional StrDelim As String, Optional bRow As Boolean) As String
Dim x
If StrDelim = vbNullString Then StrDelim = ","
x = Application.Transpose(rng1)
If bRow Then x = Application.Transpose(x)
ConCat = Join(x, StrDelim)
End Function
In the example below
the formula (D1) is =concat(A1:C1,",",TRUE)
the formula in E1 is =concat(E3:E5,", ")
You can always use Visual Basic For Applications (VBA). It is microsofts language for Office. Here is an example of what you might be looking for but try the Google Machine to learn more about VBA and how to input this code into your spreadsheet.
Sub ConcatColumns()
Do While ActiveCell <> "" 'Loops until the active cell is blank.
'The "&" must have a space on both sides or it will be
'treated as a variable type of long integer.
ActiveCell.Offset(0, 1).FormulaR1C1 = _
ActiveCell.Offset(0, -1) & " " & ActiveCell.Offset(0, 0)
ActiveCell.Offset(1, 0).Select
Loop
End Sub
I'm not entirely sure how to word this but, I have an Excel macro that enables a search functionality within my workbook. My issue is that I need the search to understand 'é' as 'e'. So that if I search for 'Belem', my result would come back with 'Belém'. How would I go about this? Thanks for any time and consideration.
Sub city()
If ActiveSheet.Name <> "City" Then Exit Sub
LastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
Sheets("Results").Range("3:10000").Delete
SearchTerm = Application.InputBox("What are you looking for?")
Application.ScreenUpdating = False
Range("W1") = SearchTerm
Range("W2:W" & LastRow).FormulaR1C1 = _
"=IF(ISERR(SEARCH(R1C23,RC[-22]&RC[-21]&RC[-20]&RC[-19]&RC[-18]&RC[-17]&RC[-16]&RC[-15]&RC[-15]&RC[-14]&RC[-13]&RC[-12]&RC[-11]&RC[-10]&RC[-9]&RC[-8]&RC[-7]&RC[-6]&RC[-5]&RC[-4]&RC[-3]&RC[-2]&RC[-1])),0,1)"
If WorksheetFunction.CountIf(Columns(23), 1) = 0 Then
Columns(23).Delete
Application.ScreenUpdating = True
MsgBox "None found."
Else
For Each Cell In Range("A2:A" & LastRow)
If Cell.Offset(, 22) = 1 Then
Cell.Resize(, 51).Copy Sheets("Results").Range("A" & Rows.Count).End(xlUp).Offset(1)
x = x + 1
End If
Next Cell
Columns(22).Delete
Application.ScreenUpdating = True
If x = 1 Then
MsgBox "1 matching record was copied to Search Results tab."
Else
MsgBox x & " matching records were copied to Search Results tab."
End If
End If
End Sub
You can modify the search parameter and then use the like operator as follows:
Sub city()
Dim rngResult As Range
Dim searchTerm As String, counter As Integer
Dim values As Variant, value As Variant
If ActiveSheet.Name <> "City" Then Exit Sub
'First Cell with the results
Set rngResult = <First cell of the result Range>
'Uses a variant array to get all values from the range. This speeds up the routine
values = <Area of Search>.Value
'Converts to lowercase to do a case insensitive search (e.g. Belem = belem)
searchTerm = LCase(Application.InputBox("What are you looking for?"))
If searchTerm = "" Then Exit Sub
' "§" is just a placeholder
searchTerm = Replace(searchTerm, "e", "§")
searchTerm = Replace(searchTerm, "é", "§")
searchTerm = Replace(searchTerm, "§", "[eé]")
Application.ScreenUpdating = False
counter = 0
For Each value In values
If LCase(value) Like searchTerm Then
rngResult = value
Set rngResult = rngResult.Offset(1, 0) 'Moves to the next line
counter = counter + 1
End If
Next value
If counter = 0 Then
MsgBox "None found."
Else
MsgBox "Found " & counter & " results"
'Do what you need to do with the results
End If
Application.ScreenUpdating = True
End Sub
All the results will be at the column of rngResult.
The code works by replacing "e" and "é" by "§" and then replacing "§" by "[eé]", (e.g. "bélem" -> "bél§m" -> "b§l§m" -> "b[eé]l[eé]m").
The like will match either "e" or "é" on that position. You can learn more about it here or in the help files. Here is a Example:
bélem Like "b[eé]l[eé]m" ' true
belem like "b[eé]l[eé]m" ' true
recife like "b[eé]l[eé]m" ' false
You can search more graphs by adding other criteria like:
'Like will match "a","á", "à" and "ã"
searchTerm = Replace(searchTerm, "a", "§")
searchTerm = Replace(searchTerm, "á", "§")
searchTerm = Replace(searchTerm, "à", "§")
searchTerm = Replace(searchTerm, "ã", "§")
searchTerm = Replace(searchTerm, "§", "[aáàã]")
This method has the advantage that you only need one "translation" in order to do comparisons. This can improve the performance if you have a large dataset
You can keep an array of all the characters you want to replace and what you want to replace them with. It's easier if you "search" your data a little differently that using that formula. Here's how I would do it.
Sub FindCity()
Dim shResults As Worksheet
Dim vaData As Variant
Dim i As Long, j As Long
Dim sSearchTerm As String
Dim sData As String
Dim rNext As Range
'Put all the data into an array
vaData = ActiveSheet.UsedRange.Value
'Get the search therm
sSearchTerm = Application.InputBox("What are you looking for?")
'Define and clear the results sheet
Set shResults = ActiveWorkbook.Worksheets("Results")
shResults.Range("A3").Resize(shResults.UsedRange.Rows.Count, 1).EntireRow.Delete
'Loop through the data
For i = LBound(vaData, 1) To UBound(vaData, 1)
For j = LBound(vaData, 2) To UBound(vaData, 2)
'Get rid of diacritial characters
sData = LCase(Anglicize(vaData(i, j)))
'Look for a match
If InStr(1, sData, LCase(Anglicize(sSearchTerm))) > 0 Then
'Write the row to the next available row on Results
Set rNext = shResults.Cells(shResults.Rows.Count, 1).End(xlUp).Offset(1, 0)
rNext.Resize(1, UBound(vaData, 2)).Value = Application.Index(vaData, i, 0)
'Stop looking in that row after one match
Exit For
End If
Next j
Next i
End Sub
Public Function Anglicize(ByVal sInput As String) As String
Dim vaGood As Variant
Dim vaBad As Variant
Dim i As Long
Dim sReturn As String
'Replace any 'bad' characters with 'good' characters
vaGood = Split("S,Z,s,z,Y,A,A,A,A,A,A,C,E,E,E,E,I,I,I,I,D,N,O,O,O,O,O,U,U,U,U,Y,a,a,a,a,a,a,c,e,e,e,e,i,i,i,i,d,n,o,o,o,o,o,u,u,u,u,y,y", ",")
vaBad = Split("Š,Ž,š,ž,Ÿ,À,Á,Â,Ã,Ä,Å,Ç,È,É,Ê,Ë,Ì,Í,Î,Ï,Ð,Ñ,Ò,Ó,Ô,Õ,Ö,Ù,Ú,Û,Ü,Ý,à,á,â,ã,ä,å,ç,è,é,ê,ë,ì,í,î,ï,ð,ñ,ò,ó,ô,õ,ö,ù,ú,û,ü,ý,ÿ", ",")
sReturn = sInput
For i = LBound(vaBad) To UBound(vaBad)
sReturn = Replace$(sReturn, vaBad(i), vaGood(i))
Next i
Anglicize = sReturn
End Function
List of characters from Excel 2007 VBA Converting Accented Characters to Regular