I'm trying to write a code that sorts two columns in a worksheet but having difficulties due to there being zeros and blanks.
I need to sort by date (earliest to oldest), then sort the data in terms of premium (largest to smallest but there will be blanks or zero premiums entered).
I'd like the macro to order the sheet so it shows the date (earliest) and then premium (largest) in order.
Here is what I have so far and it's not quite working, please can someone help?
P = date
F = premium values
Range = A2:BA5000 (entries shouldn't exceed this number and it isn't a table)
There will always be something in A3 (this is a policy number, anything entered into the sheet must have a policy number)
The spreadsheet is saved on SharePoint and autosave is on
Sub MultiLevelSort()
Worksheets("Portfolio Tracker").Unprotect Password:="Password"
Worksheets("Portfolio Tracker").Sort.SortFields.Clear
Range("A3", Range("A3").End(xlDown)).Sort Key1:=Range("F3"), Key2:=Range("P3"), Header:=xlYes, _
Order1:=xlAscending, Order2:=xlDescending
Worksheets("Portfolio Tracker").Protect Password:="Password", AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True, DrawingObjects:=True, Scenarios:=False, AllowDeletingRows:=True
End Sub
Any help would be amazing as it's driving me crazy.
Sort a Range
The Before and the After
The Code
Option Explicit
Sub MultiLevelSort()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Portfolio Tracker")
ws.Unprotect Password:="Password"
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim rg As Range: Set rg = ws.Range("A3", ws.Cells(lRow, "BA"))
ws.Sort.SortFields.Clear
rg.Sort Key1:=rg.Columns(6), Order1:=xlAscending, _
Key2:=rg.Columns(16), Order2:=xlDescending, _
Header:=xlNo
ws.Protect Password:="Password", AllowSorting:=True, AllowFiltering:=True, _
AllowUsingPivotTables:=True, DrawingObjects:=True, Scenarios:=False, _
AllowDeletingRows:=True
End Sub
Related
In an Excel workbook, I have two worksheets with similar structures.
I wrote VBA code that:
converts format from the text to the data in a range;
sorts the date in a range from oldest to the newest;
filters in a range by the specific characters (the full name of the head of the department, e.g. J.S.Doe);
makes active and moves the view to the top left corner cell in both worksheets;
goes to the next worksheet and repeats the code, then goes to the previous worksheet.
Sub SuperiorsOrders()
Application.ScreenUpdating = False
Range("I3", Range("I3").End(xlDown)).TextToColumns FieldInfo:=Array(1, 4)
Range("A3", "J3").End(xlDown).Sort [I2], xlAscending, Header:=xlYes
Range("A3", "J3").End(xlDown).AutoFilter Field:=8, Criteria1:="J.S.Doe"
Range("A1").Select
Application.GoTo ActiveSheet.Range("A1"), Scroll:=True
ActiveSheet.Next.Select
Range("I3", Range("I3").End(xlDown)).TextToColumns FieldInfo:=Array(1, 4)
Range("A3", "J3").End(xlDown).Sort [I2], xlAscending, Header:=xlYes
Range("A3", "J3").End(xlDown).AutoFilter Field:=8, Criteria1:="J.S.Doe"
Range("A1").Select
Application.GoTo ActiveSheet.Range("A1"), Scroll:=True
ActiveSheet.Previous.Select
Application.ScreenUpdating = True
End Sub
To reduce the code, I tried to wrap it into the For Each loop statement. It still works, but only for active worksheet, not for all of them.
Sub SuperiorsOrders()
Application.ScreenUpdating = False
Dim WS As Worksheet
For Each WS In Worksheets
Range("I3", Range("I3").End(xlDown)).TextToColumns FieldInfo:=Array(1, 4)
Range("A3", "J3").End(xlDown).Sort [I2], xlAscending, Header:=xlYes
Range("A3", "J3").End(xlDown).AutoFilter Field:=8, Criteria1:="J.S.Doe"
Range("A1").Select
Application.GoTo ActiveSheet.Range("A1"), Scroll:=True
Next WS
Application.ScreenUpdating = True
End Sub
I searched the internet, including similar questions here, but it does not work for me.
You have to add the worksheet reference to the range in the loop otherwise Range always refers to the active sheet
ws.Range("I3", ws.Range("I3").End(xlDown)).TextToColumns FieldInfo:=Array(1, 4)
' add the remaining lines of code starting with ws.
or
With ws
.Range("I3", .Range("I3").End(xlDown)).TextToColumns FieldInfo:=Array(1, 4)
' add the remaing lines of code in the same way
End With
So your code would look like that
Sub SuperiorsOrders()
Application.ScreenUpdating = False
Dim WS As Worksheet
For Each WS In Worksheets
With WS
.Range("I3", .Range("I3").End(xlDown)).TextToColumns FieldInfo:=Array(1, 4)
.Range("A3", "J3").End(xlDown).Sort [I2], xlAscending, Header:=xlYes
.Range("A3", "J3").End(xlDown).AutoFilter Field:=8, Criteria1:="J.S.Doe"
' .Range("A1").Select That is not necessary
End With
'Application.GoTo ActiveSheet.Range("A1"), Scroll:=True <= What is that good for?
Next WS
Application.ScreenUpdating = True
End Sub
I have a roster of names pulled from another sheet then auto sorted using macros.
When the formula returns no value "empty text" it is pushed to the top. How do I push it to the bottom while still returning the sorted value ascending?
Public Sub Worksheet_Activate()
Sheet6.Unprotect Password:="xxxxxxx"
Range("A1:F151").Sort Key1:=Range("A1"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
Sheet6.Protect Password:="xxxxxxx", _
DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Sort Ascending: Blanks to the Bottom
Uncomment the Debug.Print lines to monitor the ranges at the four 'stages'.
The Code
Option Explicit
Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
Me.Unprotect Password:="xxxxxx"
' Define constants.
Const Cols As String = "A:F"
Const FirstRow As Long = 1
Const CriteriaColumn As Long = 1
' Define Source Range (There are many ways).
' Define Processing Range (from defined first row to bottom-most row).
With Columns(Cols).Resize(Rows.Count - FirstRow + 1).Offset(FirstRow - 1)
' Validate Criteria Column.
If .Columns.Count < CriteriaColumn Then
Exit Sub
End If
' Define Source First Cell Range ('fCell').
Dim fCell As Range
Set fCell = .Cells(1)
'Debug.Print fCell.Address
' Define Source Range ('rng').
Dim rng As Range
Set rng = Intersect(fCell.CurrentRegion, .Cells)
'Debug.Print rng.Address
End With
' Sort Source Range.
' Sort descending.
rng.Sort Key1:=fCell.Offset(, CriteriaColumn - 1), _
Order1:=xlDescending, _
Header:=xlYes
' Define Last Non-Blank Cell in Criteria Column ('lCell').
Dim lCell As Range
Set lCell = rng.Columns(CriteriaColumn).Find(What:="*", _
LookIn:=xlValues, _
SearchDirection:=xlPrevious)
'Debug.Print lCell.Address
' Define Non-Blank Range ('rng').
Set rng = rng.Resize(lCell.Row - rng.Row + 1)
'Debug.Print rng.Address
' Sort Non-Blank Range ascending.
rng.Sort Key1:=fCell.Offset(, CriteriaColumn - 1), _
Order1:=xlAscending, _
Header:=xlYes
Me.Protect Password:="xxxxxx", _
DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
I've been struggling for several hours to set row heights for an implied range. The code works except for two problems 1. ALL rows with data are set to AutoFit instead of just the intended range and 2. I cannot seem to add '3' to the row height per the 2nd to last line of code:
Sub SetRH()
ActiveSheet.Unprotect
Application.ScreenUpdating = False
Range("C" & (ActiveCell.row)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection.Offset(0, 0), Selection.Offset(0, 4)).Select
Selection.sort Key1:=Range("C6"), Order1:=xlAscending, Key2:=Range("E6") _
, Order2:=xlAscending, Key3:=Range("D6"), Order3:=xlAscending, Header _
:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
For Each row In ActiveSheet.UsedRange.Rows: Rows.AutoFit: Next
For Each row In ActiveSheet.UsedRange.Rows: Rows.RowHeight = Rows.RowHeight + 3: Next
Application.ScreenUpdating = True
End Sub
Any help is much appreciated!
The below code will loop through each row auto fit and then increase the row height by +3.
Dim ws As Worksheet
Set ws = ActiveSheet
Dim Rng As Range
Dim cel As Range
Set Rng = Range(ActiveCell, Cells(Rows.Count, ActiveCell.Column).End(xlUp))
For Each cel In Rng
cel.Rows.AutoFit
cel.Rows.RowHeight = cel.Rows.RowHeight + 3
Next cel
I have two vba Code and i want to combine as single process. Need someone help please.
1st Code:
Sub DelAllZeros()
Application.Calculation = xlCalculationManual
Dim ws As Worksheet
For Each ws In Worksheets
On Error Resume Next
Set frange = ws.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not frange Is Nothing Then
For Each c In frange
If c.Value = 0 Then
c.Formula = ClearContents
End If
Next c
End If
Set frange = Nothing
Next ws
End Sub
2nd Code:
Sub DelAllZeros1()
Dim ws As Worksheet
For Each ws In Worksheets
On Error Resume Next
ws.Select
Cells.Replace What:="0", Replacement:="", LookAt:=xlWhole, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next ws
End Sub
1st code will clear the "0" from formula cells and seconds code will clear non formula cells.
Try the code below (modifications inside the code comments)
Option Explicit
Sub DelAllZerosCombined()
Application.Calculation = xlCalculationManual
Dim ws As Worksheet, c As Range, Rng As Range
For Each ws In Worksheets
' set range to occupied range in worksheet (save time in loop)
Set Rng = ws.Range("A1:" & ws.Cells.SpecialCells(xlCellTypeLastCell).Address)
If Not Rng Is Nothing Then
For Each c In Rng
If c.Value = 0 Then
' unmerge "merged" cells
If c.MergeCells Then c.UnMerge
c.ClearContents
End If
Next c
End If
Set Rng = Nothing
Next ws
' resume setting
Application.Calculation = xlCalculationAutomatic
End Sub
Try this code. This will clear the 0s from the used range in a sheet without changing the format.
Updated:
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Replace what:=0, Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next ws
Use the setting in File > Options > Advanced and untick the "Show zeros ..." setting. This setting is on a per sheet basis, so, to automate it for the whole workbook, put this code into the ThisWorkbook module
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
ActiveWindow.DisplayZeros = False
End Sub
Now zeros will not display on any sheet.
I am trying to create a pivot table from a .csv file. But I am having a run time error 1004: Reference is not valid over at the ActiveWorkbook portion of the code.
Any suggestions for this?
My code is as follows
Sub test()
Dim ws As Worksheet
Set ws = ActiveSheet
Sheets.Add
ws.Select
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
ws.Name & "R1C1:R101643C21", Version:=xlPivotTableVersion10). _
CreatePivotTable TableDestination:="Sheet1!R3C1", TableName:="PivotTable1" _
, DefaultVersion:=xlPivotTableVersion10
End Sub
I did a Sheets.Add to add in new worksheet. I used a ws.Name as the name can be any name. Just an addition question, is it possible to change R1C1:R101643C21 to a varying range as the data may not be that big or small?
Notice the ! in SourceData. The missing ! is causing the invalid reference
Sub test()
Dim ws As Worksheet
Set ws = ActiveSheet
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
ws.Name & "!R1C1:R11C2", Version:=xlPivotTableVersion10). _
CreatePivotTable TableDestination:="Sheet2!R3C1", TableName:="PivotTable1" _
, DefaultVersion:=xlPivotTableVersion10
End Sub
For dynamic range, see this
Sub test()
Dim ws As Worksheet
Dim rng As Range
Set ws = ActiveSheet
Set rng = ws.Range("A1:B10")
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
rng, Version:=xlPivotTableVersion10). _
CreatePivotTable TableDestination:="Sheet2!R3C1", TableName:="PivotTable1" _
, DefaultVersion:=xlPivotTableVersion10
End Sub
Just a reminder, you are only creating a empty pivot table in this way