Need help filtering an excel sheet for determined conditions - excel

Hi I'm having an issue with filtering an excel sheet. Basically I'm extracting a very long pdf to excel.
From the data exported I'm only interested in some codes that come in the form of SM12345 (SM and five numbers).
I was able to create a formula in excel to check for 3 conditions I defined to filter the data but it only check on a single cell value(I can't seem to find how to refer to the whole sheet as range, as in the search function).
My idea is to use advance filtering and use my 3 conditions as criteria but I don't know how to refer to the whole sheet in excel, so then I record a macro and copy those in a separate column.
My conditions are:
1- Contains "SM"
2- The length is 7 (though I think I could use wild characters after SM, not sure)
3- The string contains numbers
This is the excel formula I have for a single cell:
=IF(AND(ISNUMBER(SEARCH("sm",A9)),LEN(A9)=7,COUNT(FIND({0,1,2,3,4,5,6,7,8,9},A9))>0),A9,"")

First find all SM* and select them all with ctrl+a in the find box as shown in the image. After closing the find box all the cells will remain selected and then you can run the following macro. Then you can do anything with those cells looping myRng.
Sub SlectCond()
Dim myRng As Range
For Each cell In Selection
If HasNumber(cell.Value) And Len(cell) >= 7 Then
If myRng Is Nothing Then
Set myRng = cell
Else
Set myRng = Union(myRng, cell)
End If
End If
Next
For Each cell In myRng
cell.Interior.ColorIndex = 6
Next
End Sub
Function HasNumber(strData As String) As Boolean
Dim iCnt As Integer
For iCnt = 1 To Len(strData)
If IsNumeric(Mid(strData, iCnt, 1)) Then
HasNumber = True
Exit Function
End If
Next iCnt
End Function
Or if you want to execute all through a macro........
Sub SlectCond()
Range(Range("A1"), Range("A1").SpecialCells(xlLastCell)).Select
Selection.SpecialCells(xlCellTypeConstants, 23).Select
Dim myString, myStringArr
myString = ""
Dim myRng As Range
For Each cell In Selection
If HasNumber(cell.Value) And InStr(1, cell.Value, "SM") And Len(cell) >= 7 Then
If myRng Is Nothing Then
Set myRng = cell
myString = cell.Value
Else
Set myRng = Union(myRng, cell)
myString = myString & "," & cell.Value
End If
End If
Next
For Each cell In myRng
cell.Interior.ColorIndex = 6
Next
myStringArr = Split(myString, ",")
Worksheets.Add
For i = 0 To UBound(myStringArr)
Range("A" & i + 1) = myStringArr(i)
Next
End Sub
Function HasNumber(strData As String) As Boolean
Dim iCnt As Integer
For iCnt = 1 To Len(strData)
If IsNumeric(Mid(strData, iCnt, 1)) Then
HasNumber = True
Exit Function
End If
Next iCnt
End Function

Related

Find previous cell address (to the left) in active row with different value than active cell value

I,ve tried to find a VBA solution for finding the previous cell (located on the same row) with different value than the selected cell has. So if the selected cell is for example [N6] (as in my picture) then my search range should be ("A6:N6") from which I need to find the last cell with a different cell value (which would be cell [L6] in my picture because it's the previous cell with a different value than cell [N6]. The search should start from the end (N6,M6,L6...) backwards until the first match is found (first different cell value). When the first match is found then select it. I have hundreds of columns, so my picture is just to show the principle. I execute my vba code with Private Sub Worksheet_SelectionChange(ByVal Target As Range) so when the user selects a cell with the mouse. I get the desired cell with {=ADDRESS(6;MATCH(2;1/(A6:O6<>"D")))} but I would need a VBA solution for my problem. My current VBA solution takes me to cell [I6] instead of [L6] and I can't figure out how to edit my code to find the correct cell ([L6] in my example picture).
Dim rngSel As String, rngStart As String
Dim rngActiveStart As Range
rngSel = ActiveCell.Address(0, 0)
rngStart = Cells(ActiveCell.Row, 1).Address(0, 0)
Set rngActiveStart = Range(rngStart & ":" & rngSel)
Dim c
For Each c In rngActiveStart.Cells
If c <> Target.Value And c.Offset(0, 1) = Target.Value Then
c.Select
MsgBox "Previous different cell: " & c.Address(0, 0)
Exit For
End If
Next
Using selection_Change
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Long, col As Long, x
Dim v As String
r = Target.Row
v = Target.Value
Application.EnableEvents = False
For x = Target.Column To 1 Step -1
With Me
If .Cells(r, x) <> v Then
.Cells(r, x).Select
Exit For
End If
End With
Next x
Application.EnableEvents = True
End Sub
You need a For i = max To min Step -1 loop to loop backwards/left:
Public Sub MoveLeftUntilChange()
Dim SelRange As Range 'remember the selected range 'N6
Set SelRange = Selection
Dim iCol As Long
For iCol = SelRange.Column To 1 Step -1 'move columns leftwards
With SelRange.Parent.Cells(SelRange.Row, iCol) 'this is the current row/column to test againts the remembered range N6
If .Value <> SelRange.Value Then 'if change found select and exit
.Select
Exit For
End If
End With
Next iCol
End Sub

Excel VBA: Skip the copied cell in for loop

I have a some data where I have some conditions. If each cell in column B contains words like "and", "or", "and/or", then create a copy of that row and insert it into next row following the copied row.
Currently my data looks like this:
This is my code:
Sub Macro2()
Dim rng As Range, cell As Range, rowRange As Range
Set rng = Range("B1", Range("B1").End(xlDown))
Dim values As Variant
Dim Result() As String
connectorArray = Array("and/or", "or", "and")
Dim findConnectorWord As String
'Worksheets("Sheet1").Activate
'Range("B1", Range("B1").End(xlDown)).Select
For Each cell In rng
findConnectorWord = FindString(cell.Value, connectorArray)
If findConnectorWord <> vbNullString Then
Result() = Split(cell, findConnectorWord)
Set rowRange = Range("A" & cell.Row, Range("B" & cell.Row).End(xlToRight))
rowRange.Copy
rowRange .Offset(1, 0).Insert Shift:=xlDown
'Logic to skip the next cell
End If
Next cell
End Sub
Function FindString(SearchString As String, arr As Variant) As String
For Each searchWord In arr
If InStr(SearchString, searchWord) > 0 Then
FindString = searchWord
Exit For
End If
Next
End Function
The problem that I am having is that once the row is copied and inserted into the next row, the next iteration reads the copied row("Homeowners or Dwelling Fire") and creates another copy. What I would like to do is to skip the cell once the row is copied, inside the if condition and look at Cell B3(Assuming that Umbrella (C) gets pushed down when the new cell is copied over). What's the best possible way to do this?
One of the possible options for implementing what #freeflow wrote about in his comment:
...
Set cell = Range("B1").End(xlDown) ' start from last cell
Do Until False
findConnectorWord = FindString(cell.Value, connectorArray)
If findConnectorWord <> vbNullString Then
...
Set rowRange = cell.EntireRow
rowRange.Copy
rowRange.Offset(1, 0).Insert Shift:=xlDown
End If
If cell.Row = 1 Then Exit Do ' First row? Enough
Set cell = cell.Offset(-1, 0) ' Shift up
Loop
...
And one more note - when defining values ​​for connectorArray, add spaces to the terms: " and " instead of "and". Otherwise, you can duplicate the line with some Brandon or Alexandra

Excel VBA - How to find blank cell and sum from active cell up to blank cell

I have the following code to find the first blank cell and sum the data below it at the last blank cell.
Dim r As Range
Dim lngRowStart As Long
If Range("A1").Formula <> "" Then
lngRowStart = 1
Else
lngRowStart = Range("A1").End(xlDown).Row
End If
Set r = Cells(lngRowStart, 1).End(xlDown).Offset(1, 0)
If Left(r.Offset(-1, 0).Formula, 1) <> "=" Then
r.FormulaR1C1 = "=Subtotal(9,R[-" & r.Row - lngRowStart & "]C:R[-1]C)"
End If
But this assumes that the data is in column A and for the first set of continuous data, how to modify it for any active cell to sum the above continuous data?
For example:
2
4
3
Blank (SUM ABOVE=9)
1
3
2
Blank (SUM ABOVE=6)
You can use the UDF below (explanation inside the code's comments):
Function SumContinRange(CurCell As Range) As Double
Dim RngStart As Range, SumRng As Range
If CurCell <> "" Then
' find the first empty cell using the Find function
Set RngStart = Columns(CurCell.Column).Find(what:="", After:=CurCell, LookIn:=xlValues)
Else
' find the first empty cell using the Find function
Set RngStart = Columns(CurCell.Column).Find(what:="", After:=CurCell, LookIn:=xlValues, SearchDirection:=xlPrevious)
End If
' set the Sum Range
Set SumRng = Range(RngStart.Offset(-1, 0), RngStart.Offset(-1, 0).End(xlUp))
SumContinRange = WorksheetFunction.Sum(SumRng) ' return this value
End Function
Then, test it by passing the ActiveCell using the Sub below:
Sub TestFunc()
If ActiveCell.Value <> "" Then
ActiveCell.End(xlDown).Offset(1) = SumContinRange(ActiveCell)
Else
ActiveCell = SumContinRange(ActiveCell)
End If
End Sub

Macro to run on the column I have selected

I have the following macro, it adds a number of zeroes to the beginning of a string of numbers until the number has a total of 7 digits. Currently it only does the A column, I would like for it to run the macro for whichever column I have selected so I do not always have to cut and paste and recut and paste all the columns I need to run it on. ANy ideas?
Sub AddZeroes1()
'Declarations
Dim cl As Range
Dim i As Long, endrow As Long
Application.ScreenUpdating = False
'Converts the A column format to Text format
Columns("A:A").NumberFormat = "#"
'finds the bottom most row
endrow = ActiveSheet.Range("A1048576").End(xlUp).Row
'## Or, for Excel 2003 and prior: ##'
'endrow = ActiveSheet.Range("A65536").End(xlUp).Row
'loop to move from cell to cell
For i = 1 To endrow - 1
Set cl = Range("A" & i)
With cl
'The Do-While loop keeps adding zeroes to the front of the cell value until it hits a length of 7
Do While Len(.Value) < 7
.Value = "0" & .Value
Loop
End With
Next i
Application.ScreenUpdating = True
End Sub
You can update as many columns as you want by changing the target to the selection rather than a specific column. (as suggested by t.thielemans)
Try this:
Sub AddZeroesToSelection()
Dim rng As Range
Dim cell As Range
Set rng = Selection
rng.NumberFormat = "#"
For Each cell In rng
Do While Len(cell.Value) < 7
cell.Value = "0" & cell.Value
Loop
Next cell
End Sub
Change only the MyCol line:
Sub AddZeroes1()
Dim cl As Range
Dim i As Long, endrow As Long
Dim MyCol As String
MyCol = "A"
Application.ScreenUpdating = False
Columns(MyCol & ":" & MyCol).NumberFormat = "#"
endrow = ActiveSheet.Range(MyCol & "1048576").End(xlUp).Row
For i = 1 To endrow - 1
Set cl = Range(MyCol & i)
With cl
Do While Len(.Value) < 7
.Value = "0" & .Value
Loop
End With
Next i
Application.ScreenUpdating = True
End Sub
NOT TESTED
From your question:
it adds a number of zeroes to the beginning of a string of numbers until the number has a total of 7 digits
If you simply want numbers to show leading 0's until the numbers are 7 digits long, you can use a custom format of: 0000000
For example:
123
5432
26
9876543
Select the cells -> right-click -> Format Cells -> Custom -> Type in "0000000" (no quotes) -> OK
Now they should appear with the leading 0's:
0000123
0005432
0000026
9876543
If it has to be a macro, then this should work:
Sub AddZeroes1()
Selection.NumberFormat = "0000000"
End Sub

Range of cells into single cell with carriage return

I am working through my first VBA book and would appreciate if someone would point me in the right direction. How would I transfer a range of rows into a single cell with carriage returns? I would then like to repeat this action for all ranges in the column.
I think I need to:
find the first cell with a value in the column
verify that the next row is not empty
find the last cell in the range
perform "the operation" on the range
Following up on my comments. here is a very simple way to achieve what you want.
Option Explicit
'~~> You can use any delimiter that you want
Const Delim = vbNewLine
Sub Sample()
Dim rngInput As Range, rngOutput As Range
Application.ScreenUpdating = False
Set rngInput = Range("A1:A5") '<~~ Input Range
Set rngOutput = Range("B1") '<~~ Output Range
Concatenate rngInput, rngOutput
Application.ScreenUpdating = True
End Sub
Sub Concatenate(rng1 As Range, rng2 As Range)
Dim cl As Range
Dim strOutPut As String
For Each cl In rng1
If strOutPut = "" Then
strOutPut = cl.Value
Else
strOutPut = strOutPut & Delim & cl.Value
End If
Next
rng2.Value = strOutPut
End Sub
Within the context of a worksheet-level code, the following will work. Column 2 is hard-coded, so you might want to pass in a value or otherwise modify it to fit your needs.
Dim rng As Range
Set rng = Me.Columns(2)
Dim row As Integer
row = 1
' Find first row with non-empty cell; bail out if first 100 rows empty
If IsEmpty(Me.Cells(1, 2)) Then
Do
row = row + 1
Loop Until IsEmpty(Me.Cells(row, 2)) = False Or row = 101
End If
If row = 101 Then Exit Sub
' We'll need to know the top row of the range later, so hold the value
Dim firstRow As Integer
firstRow = row
' Combine the text from each subsequent row until an empty cell is encountered
Dim result As String
Do
If result <> "" Then result = result & vbNewLine
result = result & Me.Cells(row, 2).Text
row = row + 1
Loop Until IsEmpty(Me.Cells(row, 2))
' Clear the content of the range
Set rng = Me.Range(Me.Cells(firstRow, 2), Me.Cells(row, 2))
rng.Clear
' Set the text in the first cell
Me.Cells(firstRow, 2).Value2 = result

Resources