Search for string in each open worksheet - vba

I would like to use values from each instance of the string FindString to populate textboxes in UserForm1.
I am getting the unique WorkSheet per textbox. But the rest of the values are from the sheet active when I run the module.
This mean the string Rng isn't looping through the WorkSheets, but staying with the initial WorkSheet. How can I remedy this?
Public Sub FindString()
Dim FindString As Variant
Dim Rng As Range
Dim SheetName As String
Dim ws As Worksheet
Dim i As Integer
Application.ScreenUpdating = False
SheetName = ActiveSheet.Name
FindString = Cells(ActiveCell.Row, 1).Value
FindString = InputBox("Enter the case number to search for:", "Case ID", FindString)
If FindString = "" Then Exit Sub
If FindString = False Then Exit Sub
i = 1
For Each ws In Worksheets
If ws.Name Like "Lang*" Then
With ws
If Trim(FindString) <> "" Then
With Range("A:A")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
UserForm1.Controls("TextBox" & i) = ws.Name & vbTab & _
Rng.Offset(0, 2).Value & vbTab & _
Rng.Offset(0, 5).Value & vbTab & _
Rng.Offset(0, 6).Value & vbTab & _
Rng.Offset(0, 7).Value & vbTab & _
Rng.Offset(0, 8).Value
i = i + 1
Else: GoTo NotFound
End If
End With
End If
End With
End If
Next ws
Sheets(SheetName).Activate
Application.ScreenUpdating = True
UserForm1.Show
Exit Sub
NotFound:
Sheets(SheetName).Activate
Application.ScreenUpdating = True
MsgBox "Case ID not found"
Exit Sub
End Sub

Got it!
Just needed to add
ws.Activate
after
If ws.Name Like "Lang*" Then

Related

Excel VBA: Split data into multiple worksheets based on row and condition

I have master list, which I want to divide into separate worksheets based on Job Role. In addition, only courses marked with an "X" should appear in the individual worksheet. See image of master list below
IMAGE
Basing off my code from this sample, but to no avail (error I had was unable to get the Match property of WorksheetFunction class): https://www.extendoffice.com/documents/excel/1174-excel-split-data-into-multiple-worksheets-based-on-column.html
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vrow, i As Integer
Dim irow As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vrow = 6
Set ws = ActiveSheet
lr = ws.Cells(vrow, ws.Columns.Count).End(xlToLeft).Column
irow = ws.Rows.Count
For i = 7 To lr
If ws.Cells(vrow, i) <> " " And Application.WorksheetFunction.Match(ws.Cells(vrow, i), ws.Rows(irow), 0) = 0 Then
ws.Cells(irow, ws.Columns.Count).End(xlUp).Offset(1) = ws.Cells(vrow, i)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Rows(irow).SpecialCells(xlCellTypeConstants))
ws.Rows(irow).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vrow, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
I think this should do what you want.
Sub Copy_To_Worksheets()
'Note: This macro use the function LastRow
Dim My_Range As Range
Dim FieldNum As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim ws2 As Worksheet
Dim Lrow As Long
Dim cell As Range
Dim CCount As Long
Dim WSNew As Worksheet
Dim ErrNum As Long
'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
'and the header of the first column, D is the last column in the filter range.
'You can also add the sheet name to the code like this :
'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
'No need that the sheet is active then when you run the macro when you use this.
Set My_Range = Range("A1:D" & LastRow(ActiveSheet))
My_Range.Parent.Select
If ActiveWorkbook.ProtectStructure = True Or _
My_Range.Parent.ProtectContents = True Then
MsgBox "Sorry, not working when the workbook or worksheet is protected", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
End If
'This example filters on the first column in the range(change the field if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
FieldNum = 1
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
'Change ScreenUpdating, Calculation, EnableEvents, ....
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
'Add a worksheet to copy the a unique list and add the CriteriaRange
Set ws2 = Worksheets.Add
With ws2
'first we copy the Unique data from the filter field to ws2
My_Range.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True
'loop through the unique list in ws2 and filter/copy to a new sheet
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)
'Filter the range
My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")
'Check if there are no more then 8192 areas(limit of areas)
CCount = 0
On Error Resume Next
CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
.Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas for the value : " & cell.Value _
& vbNewLine & "It is not possible to copy the visible data." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Split in worksheets"
Else
'Add a new worksheet
Set WSNew = Worksheets.Add(After:=Sheets(Sheets.Count))
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number > 0 Then
ErrNum = ErrNum + 1
WSNew.Name = "Error_" & Format(ErrNum, "0000")
Err.Clear
End If
On Error GoTo 0
'Copy the visible data to the new worksheet
My_Range.SpecialCells(xlCellTypeVisible).Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
' Remove this line if you use Excel 97
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
End If
'Show all data in the range
My_Range.AutoFilter Field:=FieldNum
Next cell
'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0
End With
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
If ErrNum > 0 Then
MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
& vbNewLine & "There are characters in the name that are not allowed" _
& vbNewLine & "in a sheet name or the worksheet already exist."
End If
'Restore ScreenUpdating, Calculation, EnableEvents, ....
My_Range.Parent.Select
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Here is the link:
https://www.rondebruin.nl/win/s3/win006_4.htm
Or, this.
Sub Copy_To_Workbooks()
'Note: This macro use the function LastRow
Dim My_Range As Range
Dim FieldNum As Long
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim ws2 As Worksheet
Dim MyPath As String
Dim foldername As String
Dim Lrow As Long
Dim cell As Range
Dim CCount As Long
Dim WSNew As Worksheet
Dim ErrNum As Long
'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
'and the header of the first column, D is the last column in the filter range.
'You can also add the sheet name to the code like this :
'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
'No need that the sheet is active then when you run the macro when you use this.
Set My_Range = Range("A1:D" & LastRow(ActiveSheet))
My_Range.Parent.Select
If ActiveWorkbook.ProtectStructure = True Or _
My_Range.Parent.ProtectContents = True Then
MsgBox "Sorry, not working when the workbook or worksheet is protected", _
vbOKOnly, "Copy to new workbook"
Exit Sub
End If
'This example filters on the first column in the range(change the field if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
FieldNum = 1
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
'Set the file extension/format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
If ActiveWorkbook.FileFormat = 56 Then
FileExtStr = ".xls": FileFormatNum = 56
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
End If
'Change ScreenUpdating, Calculation, EnableEvents, ....
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
'Delete the sheet RDBLogSheet if it exists
On Error Resume Next
Application.DisplayAlerts = False
Sheets("RDBLogSheet").Delete
Application.DisplayAlerts = True
On Error GoTo 0
' Add worksheet to copy/Paste the unique list
Set ws2 = Worksheets.Add(After:=Sheets(Sheets.Count))
ws2.Name = "RDBLogSheet"
'Fill in the path\folder where you want the new folder with the files
'you can use also this "C:\Users\Ron\test"
MyPath = Application.DefaultFilePath
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'Create folder for the new files
foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
MkDir foldername
With ws2
'first we copy the Unique data from the filter field to ws2
My_Range.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A3"), Unique:=True
'loop through the unique list in ws2 and filter/copy to a new sheet
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A4:A" & Lrow)
'Filter the range
My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")
'Check if there are no more then 8192 areas(limit of areas)
CCount = 0
On Error Resume Next
CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
.Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas for the value : " & cell.Value _
& vbNewLine & "It is not possible to copy the visible data." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Split in worksheets"
Else
'Add new workbook with one sheet
Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
'Copy/paste the visible data to the new workbook
My_Range.SpecialCells(xlCellTypeVisible).Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
' Remove this line if you use Excel 97
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
'Save the file in the new folder and close it
On Error Resume Next
WSNew.Parent.SaveAs foldername & _
cell.Value & FileExtStr, FileFormatNum
If Err.Number > 0 Then
Err.Clear
ErrNum = ErrNum + 1
WSNew.Parent.SaveAs foldername & _
"Error_" & Format(ErrNum, "0000") & FileExtStr, FileFormatNum
.Cells(cell.Row, "B").Formula = "=Hyperlink(""" & foldername & _
"Error_" & Format(ErrNum, "0000") & FileExtStr & """)"
.Cells(cell.Row, "A").Interior.Color = vbRed
Else
.Cells(cell.Row, "B").Formula = _
"=Hyperlink(""" & foldername & cell.Value & FileExtStr & """)"
End If
WSNew.Parent.Close False
On Error GoTo 0
End If
'Show all the data in the range
My_Range.AutoFilter Field:=FieldNum
Next cell
.Cells(1, "A").Value = "Red cell: can't use the Unique name as file name"
.Cells(1, "B").Value = "Created Files (Click on the link to open a file)"
.Cells(3, "A").Value = "Unique Values"
.Cells(3, "B").Value = "Full Path and File name"
.Cells(3, "A").Font.Bold = True
.Cells(3, "B").Font.Bold = True
.Columns("A:B").AutoFit
End With
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
If ErrNum > 0 Then
MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
& vbNewLine & "There are characters in the name that are not allowed" _
& vbNewLine & "in a sheet name or the worksheet already exist."
End If
'Restore ScreenUpdating, Calculation, EnableEvents, ....
My_Range.Parent.Select
ActiveWindow.View = ViewMode
ws2.Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
https://www.rondebruin.nl/win/s3/win006_3.htm

Finding array data in worksheet values

I have a table sort of like this:
Pendergrass (606)-663-4567
Rich (606)-667-4567
Scott (606)-987-4567
Dennis (606)-233-4567
David (606)-888-4567
Red (606)-567-4567
Wendy (606)-765-4567
Todd (606)-677-4567
Andrea (606)-780-3451
Caroline (606)-992-7865
and the code I'm using looks like this:
Private Sub CommandButton2_Click()
Dim ws As Worksheet, bFound As Boolean, rFound As Range
Dim a As Long, aNames As Variant
aNames = Array("David", "Andrea", "Caroline")
For Each ws In ThisWorkbook.Worksheets
'If ws.Name <> Worksheets("Report").Name Then
If ws.Name = "Sheet1" Then
With ws.Range("A1:E30").Cells
For a = LBound(aNames) To UBound(aNames)
Set rFound = .Find(What:=aNames(a), MatchCase:=False, LookAt:=xlWhole, SearchFormat:=False)
If Not rFound Is Nothing Then
bFound = True
With Worksheets("Report")
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) = rFound.Value
End With
End If
Next a
End With
End If
Next ws
If Not bFound Then
MsgBox "None of the sheets contains the names " & Chr(10) & _
"'" & Join(aNames, "', '") & "' in cells A1:E30.", vbInformation, "Not Found"
End If
End Sub
I would like if to take the numbers of David, Andrea and Caroline and put them any where in the Report page. This only grabs one.
Can anyone suggest where I am going wrong with this code?
Try the code below.
However, not sure why you are looping through all the sheets with For Each ws In ThisWorkbook.Worksheets , if at the following line you are checking If ws.Name = "Sheet1" Then.
You can replace the lines below (remove a For, a With and If) :
For Each ws In ThisWorkbook.Worksheets
With ws
'If ws.Name <> Worksheets("Report").Name Then
If .Name = "Sheet1" Then
With .Range("A1:E30").Cells
with a simple:
With Worksheets("Sheet1").Range("A1:E30").Cells
Code
Private Sub CommandButton2_Click()
Dim ws As Worksheet, bFound As Boolean, rFound As Range
Dim a As Long, aNames As Variant
aNames = Array("David", "Andrea", "Caroline")
For Each ws In ThisWorkbook.Worksheets
With ws
'If ws.Name <> Worksheets("Report").Name Then
If .Name = "Sheet1" Then
With .Range("A1:E30").Cells
For a = LBound(aNames) To UBound(aNames)
Set rFound = .Find(What:=aNames(a), MatchCase:=False, LookAt:=xlWhole, SearchFormat:=False)
If Not rFound Is Nothing Then
bFound = True
Worksheets("Report").Cells(Worksheets("Report").Rows.Count, 1).End(xlUp).Offset(1) = rFound.Value
Worksheets("Report").Cells(Worksheets("Report").Rows.Count, 1).End(xlUp).Offset(, 1) = rFound.Offset(, 1).Value
End If
Next a
End With
End If
End With
Next ws
If Not bFound Then
MsgBox "None of the sheets contains the names " & Chr(10) & _
"'" & Join(aNames, "', '") & "' in cells A1:E30.", vbInformation, "Not Found"
End If
End Sub

Form Data to Particular Cells

In Excel sheet2 i have Columns A & D for Name, B & E Start Date and column C & F is End Date and a Form with ComboBox (loaded with names) and two Textboxes.
I want when I click submit button it will search the columns for a name that matches the ComboBox value and then write the values of the two TextBoxes into the right adjacent two EMPTY cells
Private Sub CommandButton4_Click()
Dim irow As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet2")
With ws
.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Value = Me.Combo.Value
.Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Value = Me.sttdate.value
.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).Value = Me.enddate.Value
End With
With Me
.Combo.Value = ""
.startdate.Value = ""
.enddate.Value = ""
End With
End Sub
This code is adding value of all form into Columns A B & C
This should do the trick. I added some checks based on what you wrote in your explanation in case it helps.
Private Sub CommandButton4_Click()
Dim irow As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet2")
With ws
irow = .Range("A" & .Rows.Count).End(xlup).Row
Dim rFound as Range
Set rFound = .Range("A1:A" & iRow).Find(Me.Combo.Value, lookat:=xlWhole)
If not rFound is Nothing Then
If IsEmpty(rFound.Offset(,1)) and IsEmtpy(rFound.Offset(,2)) Then
rFound.Offset(,1) = Me.sttdate.value
rFound.Offset(,2) = Me.enddate.value
With Me
.Combo.Value = ""
.startdate.Value = ""
.enddate.Value = ""
End With
Else
Msgbox "Name already has values"
End If
Else
Msgbox "Name not Found"
End If
End Sub
This should work just fine :
Private Sub CommandButton4_Click()
Dim irow As Long, _
wS As Worksheet, _
NextRow As Long, _
cF As Range
Set wS = Worksheets("Sheet2")
With wS
With .Range("A:A")
'First, define properly the Find method
Set cF = .Find(What:=Me.Combo.Value, _
After:=.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
End With
'If there is a result, keep looking with FindNext method
If Not cF Is Nothing Then
If cF.Offset(0, 1) <> vbNullString Then
Set cF = cF.End(xlToRight).Offset(0, 1)
cF.Value = Me.sttdate.Value
cF.Offset(0, 1).Value = Me.EndDate.Value
Else
.Cells(cF.Row, "B").Value = Me.sttdate.Value
.Cells(cF.Row, "C").Value = Me.EndDate.Value
End If
Else
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
.Cells(NextRow, "A").Value = Me.Combo.Value
.Cells(NextRow, "B").Value = Me.sttdate.Value
.Cells(NextRow, "C").Value = Me.EndDate.Value
End If
End With
With Me
.Combo.Value = ""
.StartDate.Value = ""
.EndDate.Value = ""
End With
End Sub

Copy excel row in different worksheet when cell dropdown "Yes" and when "No" removes the row if "Yes" was selected previously

I am trying to copy excel row in different worksheet sheet 2 when cell dropdown "Yes" of Column F and when "No" removes the row if "Yes" was selected previously. I also wanted to check if duplicate exists in worksheet 2, then prompt user with "Yes", "No" button. If "Yes" then duplicate if "No" do nothing.
ColA:Customer Name ColB:Customer Address ColC:Customer City ColD:Cust zip ColE:Tel ColF:Yes/No
I have tried this.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim lastrow As Long
If UCase(Range("F" & ActiveCell.Row).Value) <> "YES" Then Exit Sub
With ThisWorkbook.Worksheets("Sheet2")
lastrow = Application.Max(4, .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
If WorksheetFunction.CountIf(.Range("A1:A" & lastrow), _
Range("A" & ActiveCell.Row).Value) > 0 Then Exit Sub
Response = MsgBox("Record already exists, add again?", vbQuestion + vbYesNo + 256)
If Response = vbNo Then Exit Sub
.Range("A" & lastrow).Resize(, 5).Value = _
Range("A" & ActiveCell.Row).Resize(, 5).Value
End With
Response = MsgBox("Record added")
End Sub
If I understand you correctly, you need something like this (code runs only if changed value in column F):
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastrow As Long
Dim Response
Dim rng As Range, rngToDel As Range
Dim fAddr As String
If Intersect(Target, Range("F:F")) Is Nothing Then Exit Sub
Application.EnableEvents = False
On Error GoTo ErrHandler
With ThisWorkbook.Worksheets("Sheet2")
lastrow = Application.Max(4, .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
If UCase(Target.Value) = "YES" Then
Response = vbYes
If WorksheetFunction.CountIf(.Range("A1:A" & lastrow), _
Range("A" & Target.Row).Value) > 0 Then
Response = MsgBox("Record already exists, add again?", vbQuestion + vbYesNo + 256)
End If
If Response = vbYes Then
.Range("A" & lastrow).Resize(, 5).Value = _
Range("A" & Target.Row).Resize(, 5).Value
MsgBox "Record added"
End If
ElseIf UCase(Target.Value) = "NO" Then
With .Range("A4:A" & lastrow)
Set rng = .Find(What:=Range("A" & Target.Row), _
LookIn:=xlValues, _
lookAt:=xlWhole, _
MatchCase:=False)
If Not rng Is Nothing Then
fAddr = rng.Address
Do
If rngToDel Is Nothing Then
Set rngToDel = rng.Resize(, 5)
Else
Set rngToDel = Union(rngToDel, rng.Resize(, 5))
End If
Set rng = .FindNext(rng)
If rng Is Nothing Then Exit Do
Loop While fAddr <> rng.Address
End If
If Not rngToDel Is Nothing Then
rngToDel.Delete Shift:=xlUp
MsgBox "Records from sheet2 removed"
End If
End With
End If
End With
ExitHere:
Application.EnableEvents = True
Exit Sub
ErrHandler:
Resume ExitHere
End Sub

VBA Excel AutoFilter Error

I am getting following error when trying to auto filter in vba:
The object invoked has disconnected from its clients.
So what i am trying to do is auto filter, search for empty spaces and delete the rows. Can anyone please help?
I have tried the standard solutions provided online e.g. option explicit etc but to no avail.
Data:
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lngLastRow As Long
Dim lngLastRowD As Long
Application.ScreenUpdating = False
'Concatenate the Row A and B
lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Worksheets(1).Range("D2:D" & lngLastRow).Value = Evaluate("=A2:A" & lngLastRow & "&""""&" & "B2:B" & lngLastRow)
lngLastRowD = Worksheets(1).Cells(Rows.Count, "D").End(xlUp).Row
Set ws = Worksheets(1)
Set Rng = Worksheets(1).Range("A2:A" & lngLastRowD)
With Rng
.AutoFilter field:=1, Criteria1:=""
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
ws.AutoFilterMode = False
Application.ScreenUpdating = True
ThisWorkbook.Sheets(1).Range("A2").Select
End Sub
Since Worksheets() want the name of the sheet, like "Sheet1", use sheets(1).
Why are you creating the variable ws and rng when you only use them once
I ran this and it deleted rows with no data in column A.
Private Sub Worksheet_Change()
Dim lngLastRow As Long
Dim lngLastRowD As Long
Application.ScreenUpdating = False
'Concatenate the Row A and B
lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
sheets(1).Range("D2:D" & lngLastRow).Value = Evaluate("=A2:A" & lngLastRow & "&""""&" & "B2:B" & lngLastRow)
lngLastRowD = Worksheets(1).Cells(Rows.Count, "D").End(xlUp).Row
With sheets(1).Range("A2:A" & lngLastRowD)
.AutoFilter field:=1, Criteria1:=""
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
sheets(1).AutoFilterMode = False
Application.ScreenUpdating = True
Sheets(1).Range("A2").Select
End Sub
In the end i restored in approaching the issue from another angle:
Dim i As Integer, counter As Integer
i = 2
For counter = 1 To lngLastRowD
If Worksheets(1).Range("A2:A" & lngLastRowD).Cells(i) = "" And Worksheets(1).Range("D2:D" & lngLastRowD).Cells(i) <> "" Then
Worksheets(1).Range("A2:A" & lngLastRowD).Range("A" & i & ":D" & lngLastRowD).Select
Selection.Delete
GoTo TheEND
Else
i = i + 1
Debug.Print "i is " & i
End If
Next