I am new to vba and have written some code to delete specific data and refresh 2 pivot tables. It works fine when I step through each sub but when I add the module to a button so everything is run with the press of the button all the data is deleted.
Below is the code I have written( might be a bit cumbersome but I am still learning). I Hope someone can help me.
Sub Deleteheader()
ActiveWindow.FreezePanes = False
Rows("1:4").Select
Selection.Delete Shift:=xlUp
End Sub
Sub DeleteColumns()
Dim wsAvlRpt As Worksheet, wsSetUp As Worksheet
Set wsAvlRpt = ActiveWorkbook.Worksheets("AvlRpt")
Set wsSetUp = ActiveWorkbook.Worksheets("SetUp")
ColTotal = wsAvlRpt.UsedRange.Column + wsAvlRpt.UsedRange.Columns.Count - 1
LastCol = Split(Cells(1, ColTotal).Address, "$")(1)
For i = 1 To ColTotal
ColumnName = wsAvlRpt.Cells(1, i)
Values = wsSetUp.Range("A" & Rows.Count).End(xlUp).Row
cntColName = Application.CountIf(wsSetUp.Range("A2:A" & Values), ColumnName)
If cntColName = 0 Then
wsAvlRpt.Columns(i).EntireColumn.Delete
i = i - 1
ColTotal = ColTotal - 1
End If
If ColTotal <= i Then
Exit For
End If
Next i
wsAvlRpt.Columns(7).EntireColumn.Insert
wsAvlRpt.Range("G1").Value = "Item Desc"
Columns("G:G").Select
Selection.NumberFormat = "General"
End Sub
Public Sub DeleteStatus()
Dim wsAvlRpt As Worksheet
Dim lngLastRow As Long
Dim rngAvl As Range
Set wsAvlRpt = ThisWorkbook.Worksheets("AvlRpt")
With wsAvlRpt
lngLastRow = .Range("C" & .Rows.Count).End(xlUp).Row
Set rngAvl = .Range("A2:J" & lngLastRow)
End With
Application.DisplayAlerts = False
With rngAvl
.AutoFilter field:=8, _
Criteria1:="Ongoing", _
Operator:=xlOr, _
Criteria2:="P.Label"
.Offset(0).Resize(.Rows.Count).SpecialCells(xlCellTypeVisible).Rows.Delete
End With
Application.DisplayAlerts = True
With wsAvlRpt
.AutoFilterMode = False
If .FilterMode = True Then
.ShowAllData
End If
End With
End Sub
Sub DeleteZeroInventory()
Dim wsAvlRpt As Worksheet, wsSetUp As Worksheet
Set wsAvlRpt = ActiveWorkbook.Worksheets("AvlRpt")
Set wsSetUp = ActiveWorkbook.Worksheets("SetUp")
cntZeroInventory = Application.CountIf(wsAvlRpt.Range("I:I"), "<=0.0")
If cntZeroInventory > 0 Then
Total = wsAvlRpt.Cells(Rows.Count, "A").End(xlUp).Row
wsAvlRpt.Range("$A1:J" & Total).AutoFilter field:=9, Criteria1:="<=0.0", _
Operator:=xlFilterValues
wsAvlRpt.Range("A2:J" & Total).Select
Selection.SpecialCells(xlCellTypeVisible).EntireRow.Delete
wsAvlRpt.ShowAllData
wsAvlRpt.Columns(10).EntireColumn.Insert
wsAvlRpt.Range("J1").Value = "Available Eaches"
End If
End Sub
Sub CalcEaches()
Dim LastRow As Long
Sheets("AvlRpt").Activate
LastRow = Range("I65536").End(xlUp).Row
Range("I2:I" & LastRow).Select
Selection.Offset(0, 1).Select
Selection.FormulaR1C1 = "= RC[-1] *12"
Selection = Selection.Value
End Sub
Sub AddItemDesc()
With Sheets("AvlRpt")
.Range("G2:G" & .Range("C" & Rows.Count).End(xlUp).Row).Formula = _
"=IF(ISERROR(VLOOKUP(C2,SetUp!I:J,2,FALSE)),0,VLOOKUP(C2,SetUp!I:J,2,FALSE))"
.Range("G2:G" & .Range("A" & Rows.Count).End(xlUp).Row).Value = _
.Range("G2:G" & .Range("A" & Rows.Count).End(xlUp).Row).Value
End With
End Sub
Sub DeleteStyles()
Dim wsAvlRpt As Worksheet, wsSetUp As Worksheet
Set wsAvlRpt = ActiveWorkbook.Worksheets("AvlRpt")
Dim AvlRpt As Range
Set AvlRpt = wsAvlRpt.Range("A1", Range("A1").End(xlDown).End(xlToRight))
AvlRpt.AutoFilter field:=3, Criteria1:=Array("7A37", "8A37", "CO07", "CO81"), _
Operator:=xlFilterValues
AvlRpt.CurrentRegion.Offset(1, 0).Select
With Selection
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
If wsAvlRpt.FilterMode Then
wsAvlRpt.ShowAllData
End If
End With
End Sub
Sub ClearContents()
Worksheets("CloseoutData").Range("A2:J2000").Clear
End Sub
Sub CopyDeleteAvlRpt()
Application.DisplayAlerts = False
Sheets("AvlRpt").Range("A2:J2000").Copy _
Destination:=Sheets("CloseoutData").Range("A2:J2000")
Sheets("AvlRpt").Delete
Application.DisplayAlerts = True
End Sub
Sub RefreshPivots()
ThisWorkbook.RefreshAll
End Sub
Sub PivotCopyAdults()
Dim pt As PivotTable, lRow As Long
Dim oWS_Copy As Worksheet, oWS_Paste As Worksheet
Set oWS_Copy = Sheets("Adults")
Set oWS_Paste = Sheets.Add
ActiveSheet.Name = "CloseOuts Adults"
For Each pt In oWS_Copy.PivotTables
pt.TableRange2.Copy
lRow = oWS_Paste.Cells(Rows.Count, 1).End(xlUp).Row + 1
oWS_Paste.Range("A" & lRow).PasteSpecial Paste:=xlPasteValues
oWS_Paste.Range("A" & lRow).PasteSpecial Paste:=xlPasteFormats
Next pt
oWS_Paste.Cells.Columns.AutoFit
End Sub
Sub PivotCopyYouthLadies()
Dim pt As PivotTable, lRow As Long
Dim oWS_Copy As Worksheet, oWS_Paste As Worksheet
Set oWS_Copy = Sheets("Youth&Ladies")
Set oWS_Paste = Sheets.Add
ActiveSheet.Name = "CloseOuts Youth & Ladies"
For Each pt In oWS_Copy.PivotTables
pt.TableRange2.Copy
lRow = oWS_Paste.Cells(Rows.Count, 1).End(xlUp).Row + 1
oWS_Paste.Range("A" & lRow).PasteSpecial Paste:=xlPasteValues
oWS_Paste.Range("A" & lRow).PasteSpecial Paste:=xlPasteFormats
Next pt
oWS_Paste.Cells.Columns.AutoFit
End Sub
Related
I'm working to identify rows in sheet 1 that are not blank in column A and don't have a Y or L in column V. Then I need to copy the contents of that row, then paste values to an open row on the next worksheet. Lastly, I need to clear contents on the original sheet for that row. I'm getting stuck when it comes time to paste. Error 1004 - Method 'Range' of object'_Worksheet' failed. I appreciate any help.
Option Explicit
Option Compare Text
Sub EndMove()
Dim rowCount As Long, i As Long
Dim ws As Worksheet: Set ws = ActiveSheet
ws.Range("A11").Select
rowCount = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
Application.ScreenUpdating = False: Application.EnableEvents = False
Call ShowAllRecords
For i = 11 To rowCount
If ws.Range("V" & i) <> "y" And ws.Range("V" & i) <> "l" Then
If ws.Range("A" & i) <> "" Then
Dim rowCount2 As Long, j As Long
Dim sRng As Range
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets(ActiveSheet.Index + 1)
Dim wAct As Worksheet
Dim lRow As Long
Dim End_Row As Long
Set wAct = ws
Set sRng = ws.Range("V" & i)
If Not IsDate("01 " & wAct.Name & " 2017") Or wAct.Name = "Dec" Then MsgBox "Not applicable for this sheet.": Exit Sub
If ActiveSheet.Index = ThisWorkbook.Worksheets.Count Then MsgBox "This is the last worksheet cannot move forward.": Exit Sub
wAct.unprotect
With ws2
.unprotect
If rowCount2 = "1" Then
For j = 11 To Rows.Count
If .Range("A" & j) = "" Then
End_Row = j
Exit For
End If
Next j
Else
End If
wAct.Range("A" & sRng.row & ":AD" & sRng.row + sRng.Rows.Count - 1).Copy
.Range("A" & End_Row).PasteSpecial xlPasteValuesAndNumberFormats
wAct.Range("A" & sRng.row & ":AD" & sRng.row + sRng.Rows.Count - 1).ClearContents
.Range("A1000").Value = End_Row
.protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
End With
wAct.protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
Application.CutCopyMode = False
End If
End If
Next i
Application.EnableEvents = True: Application.ScreenUpdating = True
Call FilterBlanks
MsgBox "Move Complete"
End If
End Sub
It seems there is no line in your code that would assign value to rowCount2. So when you check it in code below it gives always false and therefore skips this part
If rowCount2 = "1" Then
For j = 11 To Rows.Count
If .Range("A" & j) = "" Then
End_Row = j
Exit For
End If
Next j
Else
but that part is essential as it is the only part where End_Row is assigned value. So then when you try to do this .Range("A" & End_Row) there is nothing in End_Row. Set up a breakpoint on that line and check Locals screen for End_Row to make sure it is this.
I have two Sheets in Excel that I need to check if the columns are the same in both sheets before processing them.
I have created a macro to do this check, but I'm wondering if there is a better way to achieve this.
Sub CheckColumns()
Sheets("Source1").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Sheet1").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("Source2").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Sheet1").Select
Range("A2").Select
ActiveSheet.Paste
Range("A3") = "=IF(A1=A2,0,1)"
Range("A3").Copy
Range("A2").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Range(Selection, Selection.End(xlToLeft)).Select
ActiveSheet.Paste
Range("A4") = "=SUM(3:3)"
If Range("A4").Value = 0 Then
MsgBox "Same Columns"
Else
MsgBox "different Columns"
End If
End Sub
First of all you need to avoid selection; How to avoid using Select in Excel VBA macros
Specificaally about your code; I would try comparing two arrays as it always faster to work with arrays and also it doesn't need a dummy-sheet. However, your approach, except the selection part is faster in my mind. So I would include the explicit version of your approach shortly.
Sub CheckColumns()
Dim arrS1 As Variant, arrS2 As Variant
Dim LastRow As Long
With Worksheets("Source1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
arrS1 = .Range("A1:A" & LastRow)
End With
With Worksheets("Source2")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
arrS2 = .Range("A1:A" & LastRow)
End With
If UBound(arrS1) <> UBound(arrS2) Then
MsgBox "Different Columns"
Exit Sub
End If
same = True
For i = LBound(arrS1) to UBound(arrS1)
If arrS1(i) <> arrS1(i) Then
same = False
Exit For
End If
Next i
If same = True Then
MsgBox "Same Column"
Else
MsgBox "Item " & i & " does not match. Stopped checking further"
End If
End Sub
This is the explicit version of your method:
Sub CheckColumns()
Dim rngrS1 As Range, rngS2 As Range, rngSH As Range
Dim LastRow1 As Long, LastRow2 As Long
With Worksheets("Source1")
LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rngS1 = .Range("A1:A" & LastRow)
End With
With Worksheets("Source2")
LastRow2 = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rngS2 = .Range("A1:A" & LastRow)
End With
If LastRow1 <> LastRow2 Or rngS1(1) <> rngS2(1) Then
'Second condition checks names of the columns
MsgBox "Different Columns"
Exit Sub
End If
With Worksheets("Sheet1")
Set rngSH = .Range("A1:A" & LastRow1)
End With
rngSH.Value = rngS1.Value
Set rngSH = rngSH.Offset(0,1)
rngSH.Value = rngS2.Value
Set rngSH = rngSH.Offset(0,1)
rngSH.formula "=IF(A1=B1,0,1)"
Worksheets(Sheet1).Range("D2") = "Sum(C:C)"
If Worksheets(Sheet1).Range("D2").Value <> 0 Then
MsgBox "Different Columns"
Else
MsgBox "Same Columns"
End If
End Sub
You could declare two arrays and compare that way...
Sub Compare()
Dim FirstSheet As Variant, SecondSheet As Variant
Dim a As Long, b As Long
FirstSheet = Sheets("Source1").Range("A1:" & _
Mid(Sheets("Source1").Range("A1").End(xlToRight).Address, 2, _
InStr(Right(Sheets("Source1").Range("A1").End(xlToRight).Address, _
Len(Sheets("Source1").Range("A1").End(xlToRight).Address) - 2), "$")) & 1)
SecondSheet = Sheets("Source2").Range("A1:" & _
Mid(Sheets("Source2").Range("A1").End(xlToRight).Address, 2, _
InStr(Right(Sheets("Source2").Range("A1").End(xlToRight).Address, _
Len(Sheets("Source2").Range("A1").End(xlToRight).Address) - 2), "$")) & 1)
On Error Resume Next
For a = 1 To WorksheetFunction.Max(Sheets("Source1").Range("A1:" & _
Mid(Sheets("Source1").Range("A1").End(xlToRight).Address, 2, _
InStr(Right(Sheets("Source1").Range("A1").End(xlToRight).Address, _
Len(Sheets("Source1").Range("A1").End(xlToRight).Address) - 2), "$")) & 1).Cells.Count, _
Sheets("Source1").Range("A1:" & Mid(Sheets("Source1").Range("A1").End(xlToRight).Address, 2, _
InStr(Right(Sheets("Source1").Range("A1").End(xlToRight).Address, _
Len(Sheets("Source1").Range("A1").End(xlToRight).Address) - 2), "$")) & 1))
If FirstSheet(1, a) <> SecondSheet(1, a) Then b = b + 1
Next
On Error GoTo 0
If b = 0 Then
MsgBox "Same Columns"
Else
MsgBox "different Columns"
End If
End Sub
I've created excel vba file. However, it takes very long time to run the whole file because the total of the rows is up to 270,000 lines. Does anyone know how can I speed up the running process? Any help would be much appreciated. Thanks in advance.
Sub datemodifiedFile()
Dim File1 As Object
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set File1 = fso.getfile("C:\Users\Meg\Desktop\Master File.xlsx")
If Sheets("today").Range("B1").Value = File1.DateLastModified Then
Else
Sheets("today").Range("B1").Value = File1.DateLastModified
Dim WbB As Workbook
Set WbB = Workbooks.Open(Filename:="C:\Users\Meg\Desktop\Master File.xlsx", ReadOnly:=True)
Dim SheetB As Worksheet
Dim lastrow As Long
Set SheetB = WbB.Sheets("Sheet1")
SheetB.Select
Rows("1:1").Select
'Selection.AutoFilter
'ActiveSheet.Range("A:V").AutoFilter Field:=20, Criteria1:=""
Columns("A:V").Select
Selection.Copy
ThisWorkbook.Activate
Sheets("today").Select
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Columns("A:X").Select
'ActiveSheet.Range("$A$1:$X$750001").RemoveDuplicates Columns:=Array(3, 4, 6), _
Header:=xlYes
Application.CutCopyMode = False
lastrow = Sheets("today").Range("D" & Rows.Count).End(xlUp).Row
Sheets("today").Cells(lastrow, 3).EntireRow.Delete
WbB.Close False
End If
End Sub
Sub dltnew()
Dim i As Long
Dim lrow As Long
lrow = Sheets("today").Range("C" & Rows.Count).End(xlUp).Row
For i = 2 To lrow
If Sheets("today").Cells(i, 2).Value = "NEW" Then
Sheets("today").Cells(i, 2).Value = ""
Sheets("today").Cells(i, 1).Value = ""
End If
Next i
End Sub
Sub comdate()
Dim Sheet1 As Worksheet
Dim Sheet3 As Worksheet
Dim lrow As Long
Dim i As Long
Set Sheet1 = ThisWorkbook.Sheets("main")
Set Sheet3 = ThisWorkbook.Sheets("today")
Sheet3.Range("A1").Value = Date
Sheet3.Range("A1").NumberFormat = "dd/mm/yyyy"
Sheet3.Range("A1").Font.Color = Sheet3.Range("A1").Interior.Color
Sheet3.Columns("A:A").EntireColumn.Hidden = False
If Sheet1.Range("B1").Value <> Sheet3.Range("A1").Value Then
Sheet1.Range("B1").Value = Sheet3.Range("A1").Value
lrow = Sheet1.Range("C" & Rows.Count).End(xlUp).Row
For i = 2 To lrow
If Sheet1.Cells(i, 2).Value = "NEW" Then
Sheet1.Cells(i, 2).Value = ""
End If
Next i
End If
End Sub
Sub Con()
Dim LasRow As Long
Application.ScreenUpdating = False
LasRow = Sheets("today").Range("C" & Rows.Count).End(xlUp).Row
Sheets("today").Range("A2:A" & LasRow).Formula = "=C2&G2&I2"
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
Sub Compare()
Dim mrow As Range, trow As Long
With Worksheets("main")
Set mrow = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
End With
trow = Worksheets("today").Range("A" & Rows.Count).End(xlUp).Row
With Worksheets("today")
For j = 2 To trow
If mrow.Find(What:=.Range("A" & j).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing _
Then .Range("B" & j).Value = "NEW"
Next j
End With
End Sub
Sub getnew()
Dim Sheet1 As Worksheet
Dim Sheet3 As Worksheet
Dim lastrow As Long
Dim i As Long
Dim erow As Long
Set Sheet1 = ThisWorkbook.Sheets("main")
Set Sheet3 = ThisWorkbook.Sheets("today")
lastrow = Sheet3.Range("C" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Sheet3.Cells(i, 2).Value = "NEW" Then
erow = Sheet1.Range("C" & Rows.Count).End(xlUp).Row + 1
Sheet3.Cells(i, 2).EntireRow.Copy Destination:=Sheet1.Range("A" & erow)
Application.CutCopyMode = False
Sheet1.Select
Range("A1:X750001").Select
Selection.Sort Key1:=Range("G2"), Order1:=xlAscending, Key2:=Range("C2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
End If
Next i
End Sub
Sub hidecellvalue()
Dim Sheet1 As Worksheet
Dim lastrow As Long
Dim k As Long
Set Sheet1 = ThisWorkbook.Sheets("main")
lastrow = Sheet1.Range("B" & Rows.Count).End(xlUp).Row
For k = 2 To lastrow
If Sheet1.Cells(k, 1).Value <> "NEW" Then
Sheet1.Cells(k, 1).Font.Color = Sheet1.Cells(k, 1).Interior.Color
'Sheet1.Columns("A:A").EntireColumn.Hidden = False
End If
Next k
End Sub
Sub hideSh1column()
Dim Sheet1 As Worksheet
Set Sheet1 = ThisWorkbook.Sheets("main")
Sheet1.Columns("A:A").EntireColumn.Hidden = True
Sheet1.Columns("D:F").EntireColumn.Hidden = True
Sheet1.Columns("H:H").EntireColumn.Hidden = True
Sheet1.Columns("L:L").EntireColumn.Hidden = True
Sheet1.Columns("N:N").EntireColumn.Hidden = True
Sheet1.Columns("P:P").EntireColumn.Hidden = True
End Sub
Sub HideSheet3()
Sheets("today").Visible = xlSheetVisible
End Sub
I would start with remove as much as .activate and select you have in your code and replace it with proper sheet.cell/range selection.
Then i would add this on beggining of your code
Dim previousScreenUpdating As Boolean
previousScreenUpdating = Application.ScreenUpdating
Application.ScreenUpdating = False
Dim previousCalculation As XlCalculation
previousCalculation = Application.Calculation
Application.Calculation = xlCalculationManual
and this on the end of your code
Application.ScreenUpdating = previousScreenUpdating
Application.Calculation = previousCalculation
This should be much faster.
You should always try to do as much using arrays as possible, rather than going through your data cell-by-cell.
In addition, a dictionary-based lookup is always going to beat using Find() when you're checking things in a large loop.
Sub Compare()
Dim mrow As Range, trow As Long, arr, r As Long
Dim d As Object, rngV As Range
Dim arrV, arrN, wsT As Worksheet, wsM As Worksheet
Set d = CreateObject("Scripting.Dictionary")
Set wsM = Worksheets("Main")
Set wsT = Worksheets("today")
'get all unique values in ColA on Main
arr = wsM.Range(wsM.Range("A2"), wsM.Cells(wsM.Rows.Count, 1).End(xlUp)).Value
For r = 1 To UBound(arr, 1)
d(arr(r, 1)) = 1
Next r
Set rngV = wsT.Range(wsT.Range("A2"), wsT.Cells(wsT.Rows.Count, 1).End(xlUp))
arrV = rngV.Value 'values from colA as array
arrN = rngV.Offset(0, 1).Value 'values from colB as array
'check colA against the dictionary and update colB array as needed
For r = 1 To UBound(arrV, 1)
If Not d.exists(arrV(r, 1)) Then arrN(r, 1) = "NEW"
Next r
'repopulate ColB with updated data
rngV.Offset(0, 1).Value = arrN
End Sub
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
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