I am trying to delete all "0" values from a table in excel. I have the following code written but it returns that Method 'Range of object'_Worksheet' failed. What do I need to do to fix this?
Sub Macro()
Dim ws As Worksheet
''Set reference
Set ws = ThisWorkbook.Worksheets("Compressed Schedule results")
''Apply Filter
ws.Range("A2:B2").AutoFilter Field:=1, Criteria1:="0"
lrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).SpecialCells(xlCellTypeVisible).Row
''Delete the Rows
Application.DisplayAlerts = False
ws.Range("A2:lrow").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ws.ShowAllData
End Sub
As #BigBen noted, you are referencing a range with a variable incorrectly. I also removed the SpecialCells when setting the last row:
Sub Macro()
Dim ws As Worksheet
Dim lRow As Long
''Set reference
Set ws = ThisWorkbook.Worksheets("Compressed Schedule results")
lRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
''Apply Filter
ws.Range("A2:B2").AutoFilter Field:=1, Criteria1:="0"
''Delete the Rows
Application.DisplayAlerts = False
ws.Range("A2:A" & lRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Application.DisplayAlerts = True
ws.ShowAllData
End Sub
Related
Code below - it works well for the active sheet but then doesn't do anything further, I've tried a couple of methods online but I don't understand why it won't loop through my other sheets. Any help greatly appreciated,
Sub Worksheet_Loop()
'Loop through each worksheet in a workbook
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
'What we gonna do
Dim WSR As Range
Set WSR = Range("A4:GG100")
Dim Test_Criteria As String
Test_Criteria = Range("a1")
On Error Resume Next
WSR.ShowAllData
On Error GoTo 0
WSR.Range("a4:gg1000").AutoFilter Field:=6, Criteria1:="<>" & Test_Criteria, Operator:=xlFilterValues
'2. Delete Rows
Application.DisplayAlerts = False
WSR.Range("a2:gg1000").SpecialCells(xlCellTypeVisible).EntireRow.Delete
Application.DisplayAlerts = True
If ActiveSheet.AutoFilterMode Then ActiveSheet.ShowAllData
Next ws
End Sub
This script loops through each value within a filtered column with the aim of filtering one by one, copy the data, create a new workbook, paste it and save it.
It it now creating a signle new workbook with all the worksheets, instead of one workbook per worksheet.
Can someone point out how can I mend the code to create one workbook per value filtered?
On the other hand, the workbook is also keeping the original sheet1. I am also looking on how to remove it, but thought it would be importat to let you know.
Sub test()
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
' -------------------
Dim x As Range
Dim rng As Range
Dim rng1 As Range
Dim last As Long
Dim sht As String
Dim newBook As Excel.Workbook
Dim Workbk As Excel.Workbook
Dim ws As Worksheet
'Specify sheet name in which the data is stored
sht = "Report"
'Workbook where VBA code resides
Set Workbk = ThisWorkbook
'New Workbook
Set newBook = Workbooks.Add(xlWBATWorksheet)
Workbk.Activate
Set ws = Workbk.Worksheets(sht)
'change filter column in the following code
last = ws.Cells(Rows.Count, "BR").End(xlUp).Row
With ws
Set rng = .Range("A1:BR" & last)
End With
ws.Range("G1:G" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BT1"), Unique:=True
For Each x In ws.Range([BT2], Cells(Rows.Count, "BT").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=7, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
newBook.Sheets.Add(After:=newBook.Sheets(newBook.Sheets.Count)).Name = x.Value
newBook.Activate
ActiveSheet.Paste
End With
Next x
' Turn off filter
ws.AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
' -------------------
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Check."
End Sub ```
Put the Workbooks.Add line inside the loop.
Option Explicit
Sub test()
Dim wb As Workbook, wbNew As Workbook
Dim ws As Worksheet, wsNew As Worksheet
Dim rng As Range, cel As Range
Dim iLastRow As Long, iLastRowBT As Long
Dim folder As String
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'Workbook where VBA code resides
Set wb = ThisWorkbook
Set ws = wb.Sheets("Report")
folder = wb.Path & "\"
With ws
'change filter column in the following code
iLastRow = .Cells(Rows.Count, "BR").End(xlUp).Row
.Range("BT:BT").Clear
.Range("G1:G" & iLastRow).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("BT1"), Unique:=True
Set rng = .Range("A1:BR" & iLastRow)
iLastRowBT = .Cells(Rows.Count, "BT").End(xlUp).Row
End With
' create workbooks
For Each cel In ws.Range("BT2:BT" & iLastRowBT)
' Open New Workbook
Set wbNew = Workbooks.Add(xlWBATWorksheet)
Set wsNew = wbNew.Sheets(1)
wsNew.Name = cel.Value
' filter and copy data
With rng
.AutoFilter
.AutoFilter Field:=7, Criteria1:=cel.Value
.SpecialCells(xlCellTypeVisible).Copy
End With
' paste and save
wsNew.Paste
wbNew.SaveAs folder & cel.Value & ".xlsx"
wbNew.Close SaveChanges:=False
Next
' Turn off filter
ws.AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
MsgBox iLastRowBT - 1 & " Workbooks created in " & folder, vbInformation
End Sub
I want to copy the value from current sheet to another workbooks with auto filter by creating new one, once I run the code I got the error:
Object variable or with block variable not set
Here's the code:
Sub copyvaluetoanothersheet()
Dim selectrange As Range
Dim wb As Workbook
Dim Dsheet As Worksheet
Dim Lastrow As Long
Application.ScreenUpdating = False
Set wb = Workbooks.Add
Set Dsheet = wb.Worksheets(1)
Lastrow = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
selectrange = Sheet2.Range("A2:BP" & Lastrow)
With Worksheets("Production data")
.AutoFilterMode = False
selectrange.AutoFilter field:="Branch", Criteria1:="Direct Response"
selectrange.SpecialCells(xlCellTypeVisible).EntireRow.Copy
End With
Dsheet.PasteSpecial xlPasteValues
Application.ScreenUpdating = True
End Sub
Many thanks
You must use Set when assigning object variables (you've done it elsewhere).
Set selectrange = Sheet2.Range("A2:BP" & Lastrow)
Note too that your mixture of sheet code names, tab names, and indexes is confusing, and that your code will error if nothing is visible.
Try following
Sub cpVisible()
Dim MyProdName As String
Dim FilteredRange As Range
Dim myArr As Variant
Sheets("Production Data").Range("$A$2:$BP$50000").AutoFilter Field:="Branch", Criteria1:="Direct Response"
Set FilteredRange = Sheets("Production Data").Range("$A$2:$BP$50000").SpecialCells(xlCellTypeVisible)
FilteredRange.Copy Sheets("Dsheet").Range("A1")
End Sub
I need to sort multiple worksheets at once using this script
Sub SortAllSheets()
Dim WS As Worksheet
ActiveSheet.Range("a2:f2").Select
Selection.Copy
On Error Resume Next
Application.ScreenUpdating = False
For Each WS In Worksheets
WS.Columns("A:F").Sort Key1:=WS.Columns("D"), Order1:=xlAscending
Next WS
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteAll
Application.ScreenUpdating = True
End Sub
Is there a way to how to define that the first row(header)in every worksheet will be excluded from the sorting? I tried to modify the data input or add some extra function, but with no success. Thanks for any advices.
an example:
Dim strDataRange As Range
Dim keyRange As Range
Set strDataRange = Range("Your Data Range")
Set keyRange = Range("Your Sort by Column")
strDataRange.Sort Key1:=keyRange, Header:=xlYes
so using your code:
Sub SortAllSheets()
Dim WS As Worksheet
ActiveSheet.Range("a2:f2").Select
Selection.Copy
On Error Resume Next
Application.ScreenUpdating = False
For Each WS In Worksheets
WS.Columns("A:F").Sort Key1:=WS.Columns("D"), Order1:=xlAscending, Header:=xlYes
Next WS
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteAll
Application.ScreenUpdating = True
End Sub
I found the code below on this site which works perfectly once I referenced the appropriate cells etc. However, I tried to modify it to keep formulas but I am not having much luck. Any help is greatly appreciated.
Sub test()
Dim names As New Collection
Dim ws As Worksheet, ws1 As Worksheet
Dim wb As Workbook
Dim lastrow As Long
Dim cell As Range
Dim nm As Variant
Dim res As Range
Dim rngHeader As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
'change "A" to column with "Names"
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
'change "A" to column with "Names"
For Each cell In .Range("A2:A" & lastrow)
On Error Resume Next
'collect unique names
names.Add CStr(cell.Value), CStr(cell.Value)
On Error GoTo 0
Next cell
'disable all filters
.AutoFilterMode = False
'change "A1:C1" to headers address of your table
Set rngHeader = .Range("A1:C1")
For Each nm In names
With rngHeader
'Apply filter to "Name" column
.AutoFilter Field:=1, Criteria1:=nm
On Error Resume Next
'get all visible rows
Set res = .Offset(2).Resize(lastrow - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
'if there is visible rows, create new WB
If Not res Is Nothing Then
'create new workbook
Set wb = Workbooks.Add
'add sheet with name form column "Names" ("Paul", "Nick" or etc)
wb.Worksheets.Add.name = nm
'delete other sheets from new wb
For Each ws1 In wb.Worksheets
If ws1.name <> nm Then ws1.Delete
Next
'copy/paste data
With wb.Worksheets(nm)
'copy headers
.Range("A1").Resize(, rngHeader.Columns.Count).Value = rngHeader.Value
'copy data
.Range("A2").Resize(res.Rows.Count, res.Columns.Count).Value = res.Value
End With
'save wb
wb.Close saveChanges:=True, Filename:=ThisWorkbook.Path & "\Spreadsheet_" & nm & ".xlsx"
Set wb = Nothing
End If
End With
Next
'disable all filters
.AutoFilterMode = False
End With
Set names = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
There is a part in your code which states that it copies / pastes data:
'copy/paste data
With wb.Worksheets(nm)
'copy headers
.Range("A1").Resize(, rngHeader.Columns.Count).Formula = rngHeader.Formula
'copy data
.Range("A2").Resize(res.Rows.Count, res.Columns.Count).Formula = res.Formula
End With
If you copy the .Formula instead of the .Value then it should work. Give it a try and let us know.