VBA search and copy - vba

I'm automating an update I have to do and part of the macro I want to write needs specific text from what gets populated.
I have the following types of text in the same column for hundreds of rows:
ScreenRecording^naushi02^procr^10035
procr^10635^ScreenRecording^misby01
ScreenRecording^liw03^procr^10046
I've bold the text I need. I want to either replace the whole text with just what I need or place what I need in the next column, same row.
I had wrote something which worked for 60 or so lines before I realised that there are variations in the format. For the main, it's all the same which is why I didn't realise at first and I've spent a lot of wasted time writing something that is now useless... so I'm asking for expert help please.
Once I've got what I need from the first row, I need to move down until the last entry repeating.
I had some code which obviously didn't work fully.
I have thought about using the text 'ScreenRecording' in a search along with the special character which I can't find on my keyboard and then trying to copy all text from that point upto and including the 2nd numerical character. I don't know how to do this, if it would work or even if it's a good idea but because I've spent so much time trying to figure it out, I need some help please.
Thanks in advance

If you always want to return the value after the word 'ScreenRecording`, you can use the following function to do so.
Include it in a SubRoutine to replace in place if needed:
Function SplitScreenRecording(sInput As String) As String
Dim a As Variant
Const SDELIM As String = "^"
Const LOOKUP_VAL As String = "ScreenRecording"
a = Split(sInput, SDELIM)
If IsError(Application.Match(LOOKUP_VAL, a, 0)) Then
SplitScreenRecording = CVErr(2042)
Else
SplitScreenRecording = a(Application.Match(LOOKUP_VAL, a, 0))
End If
End Function
Sub ReplaceInPlace()
Dim rReplace As Range
Dim rng As Range
Set rReplace = Range("A1:A3")
For Each rng In rReplace
rng.Value = SplitScreenRecording(rng.Value)
Next rng
End Sub

if you want to replace:
Sub main2()
Dim key As String
Dim replacementStrng As String
key = "ScreenRecording"
replacementStrng = "AAA"
With Worksheets("mysheet01").columns("A") '<--| change "mysheet01" and "A" to your actual sheet name and column to filter
.Replace what:=key & "^*^", replacement:=key & "^" & replacementStrng & " ^ ", LookAt:=xlPart
.Replace what:="^" & key & "^*", replacement:="^" & key & "^" & replacementStrng, LookAt:=xlPart
End With
End Sub
while if you want to place what you need in the next column:
Sub main()
Dim myRng As Range
Set myRng = GetRange(Worksheets("mysheet01").columns("A"), "ScreenRecording^") '<--| change "mysheet01" and "A" to your actual sheet name and column to filter
myRng.Offset(, 1) = "value that I need to place in next row" '<--| change the right part of the assignment to what you need
End Sub
Function GetRange(rng As Range, key As String) As Range
With rng
.AutoFilter Field:=1, Criteria1:="*" & key & "*" '<--| apply current filtering
If Application.WorksheetFunction.Subtotal(103, .Cells) > 0 Then '<--| if there are visible cells other than the "header" one
With .SpecialCells(xlCellTypeConstants)
If InStr(.SpecialCells(xlCellTypeVisible).Cells(1, 1), key & "^") > 0 Then
Set GetRange = .SpecialCells(xlCellTypeVisible) '<--|select all visible cells
Else
Set GetRange = .Resize(.Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp).row - 1).Offset(1).SpecialCells(xlCellTypeVisible) '<--|select visible rows other than the first ("headers") one
End If
End With
End If
.Parent.AutoFilterMode = False '<--| remove drop-down arrows
End With
End Function

Related

Select cells between bold cells using a loop

I am working with data where the only consistency is the layout and the bold headings to distinguish between a new date.
I am trying to find the cells in between these cells in bold, find the value "Individual" (in column A) in the selected rows, then sum the values of the given rows in column D (as there can be more then 1 row with "Individual"), and copy this new value to a different cell.
Since the cells between the bold is one date, if the value is not there, the output cell needs to shift down one without filling in anything.
Here is what I have so far:
Sub SelectBetween()
Dim findrow As Long, findrow2 As Long
findrow = range("A:A").Find("test1", range("A1")).Row
findrow2 = range("A:A").Find("test2", range("A" & findrow)).Row
range("A" & findrow + 1 & ":A" & findrow2 - 1).Select
Selection.Find("Individual").Activate
range("D" & (ActiveCell.Row)).Select
Selection.copy
sheets("Mix of Business").Select
range("C4").Select
ActiveSheet.Paste
Exit Sub
errhandler:
MsgBox "No Cells containing specified text found"
End Sub
How can I loop through the data and each time it loops through a range, no matter if it finds the value (e.g. individual) or not, shifts down one row on the output cell? Also, how can I change the findrow to be a format (Bold) rather then a value?
Here is some data for reference:
This is what I am trying to get it to look like:
So you have a good start to trying to work through your data. I have a few tips to share that can hopefully help get you closer. (And please come back and ask more questions as you work through it!)
First and foremost, try to avoid using Select or Activate in your code. When you look at a recorded macro, I know that's all you see. BUT that is a recording of your keystrokes and mouseclicks (selecting and activating). You can access the data in a cell or a range without it (see my example below).
In order to approach your data, your first issue is to figure out where your data set starts (which row) and where it ends. Generally, your data is between cells with BOLD data. The exception is the last data set, which just has a many blank rows (until the end of the column). So I've created a function that starts at a given row and checks each row below it to find either a BOLD cell or the end of the data.
Private Function EndRowOfDataSet(ByRef ws As Worksheet, _
ByVal startRow As Long, _
Optional maxRowsInDataSet As Long = 50) As Long
'--- checks each row below the starting row for either a BOLD cell
' or, if no BOLD cells are detected, returns the last row of data
Dim checkCell As Range
Set checkCell = ws.Cells(startRow, 1) 'assumes column "A"
Dim i As Long
For i = startRow To maxRowsInDataSet
If ws.Cells(startRow, 1).Font.Bold Then
EndRowOfDataSet = i - 1
Exit Function
End If
Next i
'--- if we make it here, we haven't found a BOLD cell, so
' find the last row of data
EndRowOfDataSet = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
End Function
To show you how to use that with your specific data, I've created a test subroutine indicating how to loop through all the different data sets:
Option Explicit
Public Sub DataBetween()
Dim thisWB As Workbook
Dim dataWS As Worksheet
Set thisWB = ThisWorkbook
Set dataWS = thisWB.Sheets("YourNameOfSheetWithData")
'--- find the first bold cell...
'Dim nextBoldCell As Range
'Set nextBoldCell = FindNextBoldInColumn(dataWS.Range("A1"))
'--- now note the start of the data and find the next bold cell
Dim startOfDataRow As Long
Dim endOfDataRow As Long
Dim lastRowOfAllData As Long
startOfDataRow = 3
lastRowOfAllData = dataWS.Cells(ws.Rows.Count, "A").End(xlUp).Row
'--- this loop is for all the data sets...
Loop
endOfDataRow = EndRowOfDataSet(dataWS, startOfDataRow)
'--- this loop is to work through one data set
For i = startOfDataRow To endOfDataRow
'--- work through each of the data rows and copy your
' data over to the other sheet here
Next i
startOfDataRow = endOfDataRow + 1
Do While endOfDataRow < lastRowOfAllData
End Sub
Use both of those together and see if that can get you closer to a full solution.
EDIT: I should have deleted that section of code. It was from an earlier concept I had that didn't completely work. I commented out those lines (for the sake of later clarity in reading the comments). Below, I'll include the function and why it didn't completely work for this situation.
So here's the function in question:
Public Function FindNextBoldInColumn(ByRef startCell As Range, _
Optional columnNumber As Long = 1) As Range
'--- beginning at the startCell row, this function check each
' lower row in the same column and stops when it encounters
' a BOLD font setting
Dim checkCell As Range
Set checkCell = startCell
Do While Not checkCell.Font.Bold
Set checkCell = checkCell.Offset(1, 0)
If checkCell.Row = checkCell.Parent.Rows.Count Then
'--- we've reached the end of the column, so
' return nothing
Set FindNextBoldInColumn = Nothing
Exit Function
End If
Loop
Set FindNextBoldInColumn = checkCell
End Function
Now, while this function works perfectly well, the situation is DOES NOT account for is the end of the last data set. In other words, a situation like this:
The function FindNextBoldInColumn will return nothing in this case and not the end of the data. So I (should have completely) deleted that function and replaced it with EndRowOfDataSet which does exactly what you need. Sorry about that.

Filtering depending upon the column values

I have a sheet FC, with this sheet, I have column R, S and T filled.
I would prefer to have a code, which checks if R contains "invalid" and if S and t are filled, then it should filter complete row.
I know we can use isblank function to check whether the cell is blank or not,
but I am struck how I can use a filter function with these condition .Any help will be helpful for me. I am struck how I can proceed with a vba code. Apologize me for not having a code.
You will have to somehow specify last row:
Dim lastRow, i As Long
For i = 1 To lastRow 'specify lastRow variable
If InStr(1, LCase(Range("R" & i).Value), "invalid") > 0 And Range("S" & i).Value = "" And Range("T" & i).Value = "" Then
'do work
End If
Next i
In our If condition we check three things that you asked.
Try this
Sub Demo()
Dim lastRow As Long
Dim cel As Range
With Worksheets("Sheet3") 'change Sheet3 to your data sheet
lastRow = .Cells(.Rows.Count, "R").End(xlUp).Row 'get last row in Column R
For Each cel In .Range("R5:R" & lastRow) 'loop through each cell in range R5 to lase cell in Column R
If cel.Value = "invalid" And Not IsEmpty(cel.Offset(0, 1)) And Not IsEmpty(cel.Offset(0, 2)) Then
cel.EntireRow.Hidden = True 'hide row if condition is satisfied
End If
Next cel
End With
End Sub
EDIT :
To unhide rows.
Sub UnhideRows()
Worksheets("Sheet3").Rows.Hidden = False
End Sub
Assuming Row1 is the header row and your data starts from Row2, in a helper column, place the formula given below.
This formula will return either True or False, then you may filter the helper column with either True or False as per your requirement.
=AND(R2="Invalid",S2<>"",T2<>"")
In case your header row is different, tweak the formula accordingly.
sub myfiltering()
'maybe first row always 4
firstrow=4
'last, maybe R column alaways have any entered info, so let us see what is the last
lastrow=cells(65000,18).end(xlup).row
'go ahead
for myrow=firstrow to lastrow
if cells(myrow,18)="Invalid" and cells(myrow,19)="" and cells(myrow,20)="" then
Rows(myrow).EntireRow.Hidden = True
else
Rows(myrow).EntireRow.Hidden = false
end if
next myrow
msgbox "Filter completed"
end sub
hope this will help you :)
Why you need the vba code for this problem?
Its more simple if you add a new column with if & and formula, and autofiltering within the added col.
The formula may be similar like this in the U2 cell.
=if(and(R2="invalid";S2="";T2="");"x";"")
Also set autofilter to x. :)

Select & Copy Only Non Blank Cells in Excel VBA, Don't Overwrite

I cant seem to find a solution for my application after endless searching. This is what I want to do:
I have cells in one excel sheet that can contain a mixture of dates and empty cells in one column. I want to then select the cells that have only dates and then copy them to a corresponding column in another sheet. They must be pasted in exactly the same order as in the first sheet because there are titles attached to each row. I do get it right with this code:
'Dim i As Long
'For i = 5 To 25
'If Not IsEmpty(Sheets("RMDA").Range("D" & i)) Then _
Sheets("Overview").Range("D" & i) = Sheets("RMDA").Range("D" & i)
'Next i
However, the dates in the first sheet are being updated on a daily basis and it can be that one title has not been updated (on another day) on the first sheet because the user has not checked it yet. If I leave it blank and If I follow the same procedure then it will "overwrite" the date in the second sheet and make the cell blank, which I do not want. I hope I was clear. Can someone please help me?
Regards
You can accomplish this very easily (and with little code) utilizing Excel's built-in AutoFilter and SpecialCells methods.
With Sheets("RMDA").Range("D4:D25")
.AutoFilter 1, "<>"
Dim cel as Range
For Each cel In .SpecialCells(xlCellTypeVisible)
Sheets("Overview").Range("D" & cel.Row).Value = cel.Value
Next
.AutoFilter
End With
you could try something like. This will give you the non blanks from the range, there may be an easier way... hope it helps
Sub x()
Dim rStart As Excel.Range
Dim rBlanks As Excel.Range
Set rStart = ActiveSheet.Range("d1:d30")
Set rBlanks = rStart.SpecialCells(xlCellTypeBlanks)
Dim rFind As Excel.Range
Dim i As Integer
Dim rNonBlanks As Excel.Range
For i = 1 To rStart.Cells.Count
Set rFind = Intersect(rStart.Cells(i), rBlanks)
If Not rFind Is Nothing Then
If rNonBlanks Is Nothing Then
Set rNonBlanks = rFind
Else
Set rNonBlanks = Union(rNonBlanks, rFind)
End If
End If
Next i
End Sub
Just because a cell is blank does not mean that it is actually empty.
Based on your description of the problem I would guess that the cells are not actually empty and that is why blank cells are being copied into the second sheet.
Rather than using the "IsEmpty" function I would count the length of the cell and only copy those which have a length greater than zero
Dim i As Long
For i = 5 To 25
If Len(Trim((Sheets("RMDA").Range("A" & i)))) > 0 Then _
Sheets("Overview").Range("D" & i) = Sheets("RMDA").Range("D" & i)
Next i
Trim removes all spaces from the cell and then Len counts the length of the string in the cell. If this value is greater than zero it is not a blank cell and therefore should be copied.

Use User-defined range as input for cell parsing

I'm writing a macro in Excel 2010 in order to remove line breaks in multiple cells of a column. This cells need to be selected by the user. Following this previous post I was able to create an InputBox to let the user select the range but now, I am unable to process the data within the selection.
My previous code without the selection range parsed an entire column with a regexp to find a pattern in the string within the cells and change its contents.
I did this with a For i To Rows.Count block of code like this:
For i = 1 To Rows.Count
If Not IsEmpty(Cells(i, 5).Value) Then
varString = Sheets(ActiveSheet.Name).Cells(i, 5).Text
Sheets(ActiveSheet.Name).Cells(i,5).Value=objRegExp.Replace(varString, "$1 ")
End If
Next i
Now I want to replace the static column so I can process only the user range.
In order to achieve that I tried this:
Set selection = Application.InputBox(Prompt:= _
"Please select a range to apply the remove break lines procedure.", _
Title:="Remove Line Breaks", Type:=8)
If selection Is Nothing Then
Exit Sub
End If
Set RowsNumber = selection.CurrentRegion -> This line gives me an error: "Object required"
Set RowsNumber = RowsNumber.Rows.Count
For i = 1 To RowsNumber
If Not IsEmpty(Cells(i, 5).Value) Then
varString = Sheets(ActiveSheet.Name).Cells(i, 5).Text
Sheets(ActiveSheet.Name).Cells(i, 5).Value = objRegExp.Replace(varString, "$1 ") 'Replace pattern found with regular expression in the same line
End If
Next i
How can I access the cells in the range returned by the InputBox?
I also tried changing RowsNumber with selection.Rows.Count but that way, although it doesn't gives an error, the cells used have blank string within them when I run the debugger. I think this is because I try to access row = 5 when the range could be less, i.e 3 if user just selects 3 cells.
I tried a For Each Next loop but then again, I know not how to access the cells withing the selection range.
You can iterate through the cells of a range by using For Each loop.
Below is your code modified. I have changed the name of variable Selection to rng, because Selection is Excel library built-in function and this name should be avoided.
Sub x()
Dim rng As Excel.Range
Dim cell As Excel.Range
Set rng = Application.InputBox(Prompt:= _
"Please select a range to apply the remove break lines procedure.", _
Title:="Remove Line Breaks", Type:=8)
If rng Is Nothing Then
Exit Sub
End If
For Each cell In rng.Cells
If Not IsEmpty(cell.Value) Then
varString = cell.Text
cell.Value = objRegExp.Replace(varString, "$1 ") 'Replace pattern found with regular expression in the same line
End If
Next cell
End Sub

need to apply find method within the formula for all rows

I am using vlookup in my formula in the macros . But it is taking too much time if it is applied for sheets containing more than 90k rows .
Instead i like to use find or Instr method to reduce the time . But i am getting error if i use "find: method . I dont how to use "Instr"
Sub testt()
Dim l As Long
l = Sheets(1).Range("A1:A" & Sheets(1).Cells(Sheets(1).Rows.Count, "A").End(xlUp).Row).Count
With Sheets("Sheet1")
.Range("d1").Formula = "=IF(iferror(vlookup(c1,$D:$D,1,false),"""")="""","""",1)"
.Range("d1").AutoFill Destination:=Range("d1:d" & l), Type:=xlFillDefault
End With
End Sub
here is my formula with vlookup . But i need to replace vlookup with find
l = Sheets(1).Range("A1:A" & Sheets(1).Cells(Sheets(1).Rows.Count, "A").End(xlUp).Row).Count
With Sheets("Sheet1")
.Range("d1").Formula = "=IF(iferror(range("A1:A" & l).find(c1),"""")="""","""",1)"
.Range("d1").AutoFill Destination:=Range("d1:d" & l), Type:=xlFillDefault
End With
There is no FIND function in Excel that I know of. However, you could write a VBA function to find each relevant cell in the lookup column. Here is the relevant bit of code:
Function IfFound(SearchText As String) As String
Dim FoundCell As Range
'look in particular column for a value
Set FoundCell = Columns("A:A").Find(What:=SearchText, lookat:=xlWhole)
'if found, return value in cell to its right
If FoundCell Is Nothing Then
IfFound = ""
Else
IfFound = FoundCell.Offset(0, 1).Value
End If
End Function
Here's how you could call this:
Sub TestFunction()
'make sure word TEST is in column A somewhere
MsgBox IfFound("test")
End Sub
Not sure if this is what you're looking for, but it would run much more quickly than VLOOKUP. The only problem is that you'd have to find a way to run it automatically whenever anything changed in the worksheet.