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
Related
I am working on a project to clean up a couple hundred excel sheets for an specific import spec. The import process errors out if any rows have a specific value blank, so I'm looking to find the best way to delete all rows in the entire workbook if column C in that row is empty. I found this simple VBA code that works on the active sheet, but I need it to loop through all sheets in the workbook. Any suggestions on a better process so I don't have to run it >100 times?
Sub DelBlankRows()
Columns("C:C").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
End Sub
Delete the Rows of a Column's Blanks
Option Explicit
Sub DelRowsOfColumnBlanksTEST()
Const wsCol As Variant = "C" ' or 3
'Const wsCol As String = "C"
'Const wsCol As Long = 3
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Application.ScreenUpdating = False
Dim ws As Worksheet
For Each ws In wb.Worksheets
DelRowsOfColumnBlanks ws, wsCol
Next ws
Application.ScreenUpdating = True
End Sub
Sub DelRowsOfColumnBlanks( _
ByVal ws As Worksheet, _
ByVal WorksheetColumnID As Variant)
If ws Is Nothing Then Exit Sub ' no worksheet
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
Dim urg As Range: Set urg = ws.UsedRange
If urg.Rows.Count = 1 Then Exit Sub ' only one row
On Error Resume Next
Dim crg As Range: Set crg = ws.Columns(WorksheetColumnID)
On Error GoTo 0
If crg Is Nothing Then Exit Sub ' invalid Worksheet Column ID
Dim tcrg As Range: Set tcrg = Intersect(urg, crg)
' ... is only the same as 'Set tcrg = urg.Columns(WorkhseetColumnID)',...
' ... if the first column of the used range is column 'A'.
If tcrg Is Nothing Then Exit Sub ' no intersection
Dim drg As Range: Set drg = tcrg.Resize(tcrg.Rows.Count - 1).Offset(1)
tcrg.AutoFilter 1, "=" ' ... covers blanks: 'Empty', "=""""", "'"... etc.
' Note that although it contains the word 'Blanks',...
' ... 'SpecialCells(xlCellTypeBlanks)' only covers 'Empty'.
On Error Resume Next
Dim spcrg As Range: Set spcrg = drg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not spcrg Is Nothing Then
spcrg.EntireRow.Delete
'Else
' no 'visible' cells (to delete)
End If
ws.AutoFilterMode = False
End Sub
Option Explicit
Sub CleanWorkbook()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
DeleteRowsOfEmptyColumn sh, "C"
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub DeleteRowsOfEmptyColumn(sh As Worksheet, col as string)
Dim rowsToDelete As New Collection
Dim cell
For Each cell In Intersect(sh.UsedRange, sh.Columns(col))
If cell.Value = "" Then
rowsToDelete.Add cell.Row
End If
Next
Dim i As Integer
For i = rowsToDelete.Count To 1 Step -1
sh.Rows(rowsToDelete(i)).Delete
Next
End Sub
I've put a very basic error trap for any sheets with no values in C. You may need to improve this yourself.
Edit: Updated error trap
Sub DelBlankRows()
Dim sh As Worksheet
Application.ScreenUpdating = False
On Error GoTo Handle
For Each sh In ThisWorkbook.Worksheets
sh.Activate
Columns("C:C").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
Cont:
Next sh
Application.ScreenUpdating = True
Exit Sub
Handle:
If Err.Number = 1004 Then Resume Cont
End Sub
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
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
What I want to add is.. Macro should delete the old from "Master"sheet and refresh the sheet1,sheet2 and sheet3
Sub Combine3Sheet()
Dim Ary As Variant
Dim Ws As Worksheet
Ary = Array("Sheet1", "Sheet2", "Sheet3")
Sheets("Master").Name = "Master"
For Each Ws In Worksheets(Ary)
Ws.UsedRange.Offset(1).Copy Sheets("Master") _
.Range("A" & Rows.Count).End(xlUp).Offset(1)
Application.DisplayAlerts = False
Application.DisplayAlerts = True
Call Formatting
Next Ws
End Sub
You mean this? Delete the data on Master before pasting it?
(Also stop changing the edits on your post)
Sub Combine3Sheet()
Dim Ary As Variant
Dim Ws As Worksheet
Ary = Array("Sheet1", "Sheet2", "Sheet3")
'Refresh all sources/Tables
ThisWorkbook.RefreshAll
'Clear All but first Row
Sheets("Master").Rows("2:" & Rows.Count).ClearContents
'Loop sheets
For Each Ws In Worksheets(Ary)
Ws.UsedRange.Offset(1).Copy
Sheets("Master").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Call Formatting
Next Ws
End Sub
Can some one help with a vba code to copy a range from multiple worksheets (52 weeks) into a summary sheet in the same workbook. Range is the same in each worksheet. I want the data to be copied and pasted in 52 columns in the ssummary worksheet, from week1 to week 52.
I have found this code online:
Sub SummurizeSheets()
Dim ws As Worksheet
Application.ScreenUpdating = False
Sheets("Summary").Activate
For Each ws In Worksheets
If ws.Name <> "Summary" Then
ws.Range("F46:O47").Copy
Worksheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
End If
Next ws
End Sub
Try below code .Also set Application.ScreenUpdating = True.
Sub SummurizeSheets()
Dim ws As Worksheet
Dim j As Integer, col As Integer
Application.ScreenUpdating = False
Sheets("Summary").Activate
For Each ws In Worksheets
If ws.Name <> "Summary" Then
ws.Range("k3:k373").Copy
col = Worksheets("Summary").Range("IV1").End(xlToLeft).Column + 1
Worksheets("Summary").Cells(1, col).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
Next ws
Columns(1).Delete
Range("A1").Activate
Application.ScreenUpdating = True
End Sub