I have a spreadsheet with three columns; A B and C. Values in column C are calculated using a formula, and I want to sort Z->A on column C, expanding the selection to the other two columns as well. My goal is to have the ranking automatically updated anytime a value in column C changes. I'm looking for someone who can write this for me, I know JS but not VBA and I'm having trouble figuring it out because it's not an easy one (at least for me). Thanks!
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
Application.EnableEvents = False
Columns("C").Sort Key1:=Range("C2"), Order1:=xlDescending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Application.EnableEvents = True
End If
End Sub
=IFERROR(((ABS((((SUMIF(Orders!$B$1:$BJ$1, DATE((YEAR(TODAY())), (MONTH(TODAY())), ("<"&DAY(TODAY()))), Orders!B2:BJ2))-(SUMIF(Forecast!$B$1:$BJ$1, DATE((YEAR(TODAY())), (MONTH(TODAY())), ("<"&DAY(TODAY()))), Forecast!B2:BJ2)))/(SUMIF(Orders!$B$1:$BJ$1, DATE((YEAR(TODAY())), (MONTH(TODAY())), ("<"&DAY(TODAY()))), Orders!B2:BJ2))))*(SUMIF(Orders!$B$1:$BJ$1, DATE((YEAR(TODAY())), (MONTH(TODAY())), ("<"&DAY(TODAY()))), Orders!B2:BJ2)))/(SUMIF(Orders!$B$1:$BJ$1, DATE((YEAR(TODAY())), (MONTH(TODAY())), ("<"&DAY(TODAY()))), Orders!B2:BJ2))), 0)
Place this code in the ThisWorkbook module in the Microsoft Excel Objects folder in the VBE.
This will sort by column C in the sheet (change name in code below to suit your actual sheet) anytime the workbook is recalculated. Obviously it will happen more times than needed, but it's the only way to ensure that it fires automatically.
If you have performance issues with this because of file size or amount of "recalcs" it's possible it can be tweaked a bit, or the design of the spreadsheet can be tweaked.
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
If sh.Name = "myABCSheet" or sh.Name = "Orders" or sh.Name = "Forecast"
Dim ws As Worksheet
Set ws = Worksheets("myABCSheet") 'change name as needed
With ws
Dim lRow As Long
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
With .Sort
With .SortFields
.Clear
.Add ws.Range("C1:C" & lRow), 1, xlAscending
End With
.SetRange ws.Range("A1:C" & lRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
Application.Calculation = xlManual
.Apply
Application.Calculation = xlCalculationAutomatic
End With
End With
Application.EnableEvents = True
End If
End Sub
Related
Whenever I try to highlight over column D I receive "Run-time error '13'". When I click debug it highlights this piece from the code, If Target.Value = "Closed" Or Target.Value = "Closed" Then. I would greatly appreciate any advice on how to fix this issue.
Edit*
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim wsd As Worksheet
Dim wsc As Worksheet
Application.ScreenUpdating = False
Set wsd = Sheets("Pipeline")
Set wsc = Sheets("Closed")
If Not Intersect(Target, Range("D6:D65536")) Is Nothing Then
If Target.Value = "Closed" Or Target.Value = "Closed" Then
erow = Target.Row
MsgBox "Moved to Closed"
numberofrow = wsc.Range("A65536").End(xlUp).Row
For i = 1 To numberofrow
If wsd.Cells(erow, 1) = wsc.Cells(i, 1) Then
Exit Sub
End If
Next
wsd.Range("A" & erow & ":A" & erow).EntireRow.Copy wsc.Range("A" & numberofrow + 1)
With Target.Parent
Union(.Range(.Cells(Target.Row, "A"), .Cells(Target.Row, "V")), _
.Range(.Cells(Target.Row, "Y"), .Cells(Target.Row, .Columns.Count))).ClearContents
`enter code here`End With
wsc.Activate
ActiveSheet.Range("A2:D" & numberofrow + 1).Select
ActiveWorkbook.Worksheets("Closed").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Closed").Sort.SortFields.Add Key:=Range("C2:C" & numberofrow + 1), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Closed").Sort
.SetRange Range("A2:D" & numberofrow + 1)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
wsd.Activate
End If
End If
End Sub
I had to piece a few things together in order to get this to work, which is why it's pretty ugly. I couldn't figure out where to put guard clause. This so far has worked for what I need it for (aside from the Run-time error), transferring accounts to a separate sheet based on the sales stage entered into column D. Again, I appreciate all the help.
Your handler assumes only 1 cell is selected. When you highlight an entire column, Target represents all selected cells, and then Target.Value can't be meaningfully evaluated, so it raises a run-time error.
You need to modify your handler to remove that assumption, as was suggested:
If Target.Cells.Count > 1 Then Exit Sub
Presumably that event handler needs more tweaks to verify the Target is what the macro thinks/assumes it is, but given the information you've provided that would be it.
I am creating a code that opens another file, performs some action and closes it. In the file I am opening, there is a function that organizes the data upon closing.
I do not know how to code the filter in VBA, so I recorded a macro and pasted it into my function. The code works when I run it by itself, but when I call the main function the '.Select' doesn't appear to select the cells/columns, causing a failure.
The first function is from the first workbook, and the second is being called when the first function closes the file.
'*********First Function************
Sub AddDrawing_Button() 'activated by button in worksheet
PN = Sheets("New Drawing").Range("C5").Cells(1, 1).Value 'Part Number, D
Rev = Sheets("New Drawing").Range("C5").Cells(3, 1).Value 'Revision, E
Application.ScreenUpdating = False
Workbooks.Open ("C:\Users\Desktop\MasterDataFile.xlsm") 'Finds the file
Workbooks("MasterDataFile").Worksheets("DATA").Activate
t = Sheets("DATA").Range("D65536").End(xlUp).Row + 1 'finds the bottom row + 1
Sheets("DATA").Range("D1").Cells(t, 1).Value = PN 'Part Number, D
Sheets("DATA").Range("D1").Cells(t, 8).Value = Rev 'Revision, E
Workbooks("MasterDataFile").Close SaveChanges:=True
'upon closing this file, it jumps to the following code
Application.ScreenUpdating = True
End Sub
'*********Second Function in Second Workbook************
Sub Workbook_BeforeClose(Cancel As Boolean)
Dim ThisWs As Worksheet
Dim value1 As String
Dim value2 As String
Set ThisWs = Workbooks("MasterDataFile").Worksheets("DATA")
t = ThisWs.Range("D65536").End(xlUp).Row 'end
'Application.ScreenUpdating = False
'The following 6 lines creates a new column and populates
' each row with the part number and revision combined.
Cells(1, 24) = "Order"
For s = 2 To t
value1 = Cells(s, 4)
value2 = Cells(s, 11)
ThisWs.Cells(s, 24) = value1 + "Rev" + value2
Next s
'The following was generated by recording a macro, and uses
' the filter to organize the data. The error is occurring
' because the columns are not being selected. Why?
ThisWs.Columns("D:X").Select
Selection.AutoFilter
ThisWs.AutoFilter.Sort.SortFields.Clear
ThisWs.AutoFilter.Sort.SortFields.Add Key:=Range( _
"X1:X19519"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ThisWs.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'This turns off the filter
ThisWs.Range("A1").Select
ThisWs.Columns("D:X").Select
Selection.AutoFilter
ThisWs.Range("A1").Select
'This deletes the generated column after it has been sorted
ThisWs.Columns("X:X").ClearContents
'Application.ScreenUpdating = True
End Sub
Can someone help me understand why the cells are not being selected, with a way to fix it?
Or if all else fails, can someone post a way to filter the columns without selecting anything.
Thank you.
I have rebuilt your function, It is untested and should work, but it is not completely optimised. Everything is handled in the original function and nothing is handled in the OnClose Event.
'*********First Function************
Sub AddDrawing_Button() 'activated by button in worksheet
Dim wbMasterDataFile as Workbook
Dim shtData as Worksheet
Dim t as long
Dim s as long
'PN = Sheets("New Drawing").Range("C5").Value 'Part Number, D
'Rev = Sheets("New Drawing").Range("C7").Value 'Revision, E
Application.ScreenUpdating = False
set wbMasterDataFile = Workbooks.Open ("C:\Users\Desktop\MasterDataFile.xlsm") 'Finds the file
set shtData = wbMasterDataFile.Worksheets("DATA")
with shtData
t = .Range("D65536").End(xlUp).Row + 1 'finds the bottom row + 1
.Range("D1").Cells(t, 1).Value = Sheets("New Drawing").Range("C5").Value 'Part Number, D
.Range("K1").Cells(t, 1).Value = Sheets("New Drawing").Range("C7").Value 'Revision, E
.Cells(1, 24).Value2 = "Order"
For s = 2 To t
.Cells(s, 24) = .Cells(s, 4) + "Rev" + .Cells(s, 11)
Next s
.Columns("D:X").AutoFilter
With .AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("X1:X19519"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
.Columns("D:X").AutoFilter
.Columns("X:X").ClearContents
End with
set shtData = nothing
wbMasterDataFile.Close SaveChanges:=True
set wbMasterDataFile = Nothing
'upon closing this file, it jumps to the following code
Application.ScreenUpdating = True
End Sub
I have also made some more direct references to the ranges that you are using not through the Cell function
I have to run so can't explain more but will edit with more detail later.
Thank you #Bullfrog for providing me the solution to my problem, I am only posting this because I do not want other vba users to get hung up on code that may not run.
Sub AddDrawing_Button()
Dim ThisWb As Workbook, wbMasterDataFile As Workbook
Dim ThisWs As Worksheet, shtData As Worksheet
Dim t As Long, s As Long
Dim value1 As String, value2 As String
Application.ScreenUpdating = False
Set ThisWb = Workbooks("CombinationIndex")
Set ThisWs = ThisWb.Worksheets("New Drawing")
Set wbMasterDataFile = Workbooks.Open("C:\Users\Desktop\MasterDataFile.xlsm")
Set shtData = Workbooks("MasterDataFile").Worksheets("FinalDATA")
With shtData
t = .Range("D65536").End(xlUp).Row + 1 'Finds the bottom row
.Range("D1").Cells(t, 1).Value = ThisWs.Range("C5").Value 'Part Number, D
.Range("D1").Cells(t, 8).Value = ThisWs.Range("C13").Value 'Revision , E
.Cells(1, 24).value2 = "Order" 'header to new column
For s = 2 To t
value1 = .Cells(s, 4) 'originally Bullfrog's code was giving me an error due to a type mismatch
value2 = .Cells(s, 11) 'I defined a variable above, and filled it so that it was always a string
.Cells(s, 24) = value1 + "0Rev" + value2 'will use the combined values to sort data by latest rev
Next s
.Columns("D:X").AutoFilter 'using the with function to apply the filter
With .AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("X1:X19519"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
.Columns("D:X").AutoFilter 'Turns off the filter
.Columns("X:X").ClearContents 'deletes the data
End With
Set shtData = Nothing
wbMasterDataFile.Close SaveChanges:=True 'closes the file
Set wbMasterDataFile = Nothing
Application.ScreenUpdating = True
End Sub
I would like to implement an Excel macro that sorts all columns from column "C" to the last column containing data (columns A and B shall not be affected).
The columns shall be sorted from A->Z based on the cell value of their first row (which is a string).
So far, I came up with the following code which I do not like that much because it contains hardcoded numbers for the Sort range making the code not really robust.
Sub SortAllColumns()
Application.ScreenUpdating = False
'Sort columns
With ActiveWorkbook.Worksheets("mySheet").Sort
.SetRange Range("C1:ZZ1000")
.Header = xlYes
.MatchCase = False
.Orientation = xlLeftToRight
.Apply
End With
Application.ScreenUpdating = True
End Sub
Searching the internet, one may find tons of suggestions getting the last used column or row. However most of them will blow up the code more than I expected.
I am not a VBA expert and it would be great if someone could make a suggestion how this problem can be solved in an elegant and efficient way.
If this is important: We will definitely not have more that 1000 rows and 1000 columns.
Any suggestion is highly appreciated.
edited:
changed temporary sheet adding statement to have it always as the last one
revised its deletion statement accordingly
should your need be to sort columns by moving them so as to have their headers sorted from left to right, then try this code
Option Explicit
Sub main()
Dim lastCol As Long
With Sheets("mySheet")
lastCol = .cells(1, .Columns.Count).End(xlToLeft).Column
Call OrderColumns(Range(.Columns(3), Columns(lastCol)))
End With
End Sub
Sub OrderColumns(columnsRng As Range)
Dim LastRow As Long
With columnsRng
LastRow = GetColumnsLastRow(columnsRng)
With .Resize(LastRow)
.Copy
With Worksheets.Add(after:=Worksheets(Worksheets.Count)).cells(1, 1).Resize(.Columns.Count, .Rows.Count) 'this will add a "helper" sheet: it'll be removed
.PasteSpecial Paste:=xlPasteAll, Transpose:=True
.Sort key1:=.Columns(1), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlNo
.Copy
End With
.PasteSpecial Paste:=xlPasteAll, Transpose:=True
Application.DisplayAlerts = False: Worksheets(Worksheets.Count).Delete: Application.DisplayAlerts = True 'remove the "helper" sheet (it's the (n-1)th sheet)
End With
End With
End Sub
Function GetColumnsLastRow(rng As Range) As Long
Dim i As Long
'gets last row of the given columns range
GetColumnsLastRow = -1
With rng
For i = 1 To .Columns.Count
GetColumnsLastRow = WorksheetFunction.Max(GetColumnsLastRow, .Parent.cells(.Parent.Rows.Count, .Columns(i).Column).End(xlUp).row)
Next i
End With
End Function
it makes use of a "helper" temporary (it gets deleted by the end) sheet.
Thanks to the suggestions and revisions of #SiddharthRout I got this:
Sub SortAllColumns()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim LastColumnLetter As String
Set ws = ThisWorkbook.Sheets("mySheet")
'Get range
With ws
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
LastColumnLetter = Split(.Cells(, LastColumn).Address, "$")(1)
'Sort columns
Range("C1:" & LastColumnLetter & LastRow).Select
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("C1:" & LastColumnLetter & 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange ws.Range("C1:" & LastColumnLetter & LastRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlLeftToRight
.Apply
End With
End With
Application.ScreenUpdating = True
End Sub
I'm only about three weeks into learning how to use Excel, and I have it so that all of the tables on my worksheet will sort, but not when there's a change, only when I actually visit the worksheet.
So if I input data from another source like a UserForm, it won't sort the tables again until I go back to the worksheet. Is there a way to automatically sort them so the extra visit isn't needed?
This is what I have so far:
Private Sub Worksheet_Activate()
Dim tbl As ListObject
Dim SortCol As Long
Application.ScreenUpdating = False
For Each tbl In ActiveSheet.ListObjects
If tbl.Name = "TableSORT2" Then
SortCol = 2
Else
SortCol = 1
End If
With tbl.Sort
.SortFields.Clear
.SortFields.Add Key:=tbl.DataBodyRange.Columns(SortCol), _
SortOn:=xlSortOnValues, Order:=xlAscending
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Next tbl
Application.ScreenUpdating = True
End Sub
I tried changing Private Sub Worksheet_Activate() to Private Sub Worksheet_Change() but to no avail, I'm assuming because there's more references or integration needed.
You can either take on D_Zab's advise or try below:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo halt
Application.EnableEvents = False
Dim tbl As ListObject
For Each tbl In Me.ListObjects
If Not Intersect(Target, Me.Range(tbl.Name)) Is Nothing Then
MsgBox "Table Updated"
SortTables Me 'call the sort table routine
End If
Next
moveon:
Application.EnableEvents = True
Exit Sub
halt:
MsgBox Err.Description
Resume moveon
End Sub
So above detects any changes made in any table in the sheet you put the event. Now, all you have to do is to create a sub that sorts all the tables and call it. A sample code (which is actually what you have) is below.
Private Sub SortTables(sh As Worksheet)
Dim tbl As ListObject
Dim SortCol As Long
Application.ScreenUpdating = False
For Each tbl In sh.ListObjects
If tbl.Name = "TableSORT2" Then
SortCol = 2
Else
SortCol = 1
End If
With tbl.Sort
.SortFields.Clear
.SortFields.Add Key:=tbl.DataBodyRange.Columns(SortCol), _
SortOn:=xlSortOnValues, Order:=xlAscending
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Next tbl
Application.ScreenUpdating = True
End Sub
Is this what you're trying? Btw, for some reason, this also detects changes made from UserForms. Even a simple line like Range("A2").Value = "something" is detected so long as the target range is within the Table Range. Moreover, this also detects the addition of data to tables when it auto-resize. HTH.
I'm trying to architect a macro to do the following steps:
Compare two lists of data (in this case Column A against Column C)
Output in B any cell that exists in both A and C. Line up the match next to its match in Column A.
Sort both column A and B by their values so that the corresponding cells in A and B are still next to each other after the sort.
Desired result. Notice how the matches in column A and B are still together. This enables users of this macro to quickly eliminate data that only belongs to one of the respective columns and it allows us to retain any information that may be tied to column A, e.g., Column A contains email addresses, and there is a corresponding column next to it that contains phone #'s. We don't want to split that information up. This macro would enable that:
Pastebin of excel data I used: http://pastebin.com/mYuQRMjj
This is the macro I've written, which uses a second macro:
Sub Macro()
Range(Selection, Selection.End(xlDown)).Select
Application.Run "macro4.xlsm!Find_Matches"
Range("B1:B284").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B1:B284") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:B284")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
The second macro that does the comparison is literally ripped straight from Microsoft, with a little extra.
Sub Find_Matches()
Application.ScreenUpdating = False
Dim CompareRange As Variant, x As Variant, y As Variant
' Set CompareRange equal to the range to which you will
' compare the selection.
Set CompareRange = Range("C1:C500")
' NOTE: If the compare range is located on another workbook
' or worksheet, use the following syntax.
' Set CompareRange = Workbooks("Book2"). _
' Worksheets("Sheet2").Range("C1:C5")
'
' Loop through each cell in the selection and compare it to
' each cell in CompareRange.
For Each x In Selection
For Each y In CompareRange
If x = y Then x.Offset(0, 1) = x
Next y
Next x
Application.ScreenUpdating = True
End Sub
Using these two macros, I get exactly what I want, but I don't like using limited ranges. I want the macro to be smart enough to determine exactly what the range is, because the people who will be using this macro sometimes will be using a list of 200, sometimes a list of 2,000,000. I want this macro to be a "one size fits all" for range.
I looked into this and the command:
Range(Range("B1"),Range("A1").End(xlDown)).Select
gets exactly the selection I want after Find_Matches runs (I also realize that Find_Matches is using a finite compare range . . . solving my issue for this first Macro will solve that too).
The problem is that I am unsure how to plug that into my Macro. I've tried several implementations and I'm flat out stuck. I can't find an answer for something this specific, but I know I'm very close. Thank you for any help!
edit: This whole method is realllly slow on larger lists (20+ minutes on a list of 100k). If you can suggest some ways to speed it up that would be super helpful!
Sub MatchNSort()
Dim lastrow As Long
'Tell Excel to skip the calculation of all cells and the screen
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'Find the last row in the data
With ActiveSheet
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastrow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lastrow = 1
End If
End With
'Force a formula in column B to match a from c
ActiveSheet.Range("B1:B" & lastrow).Formula = _
"=IFERROR(IF(MATCH(C[-1],C[1]:C[1],0)>0,C[-1],""""),"""")"
'Force a recalculate
Application.Calculate
'Sort columns B and A
With ActiveSheet
.Range("A1:B" & lastrow).Select
.Sort.SortFields.Clear
'First key sorts column B
.Sort.SortFields.Add Key:=Range("B1:B" & lastrow) _
, SortOn:=xlSortOnValues, Order:=xlAscending _
, DataOption:=xlSortNormal
'Second key (optional) sort column A, after defering to column B
.Sort.SortFields.Add Key:=Range("A1:A" & lastrow) _
, SortOn:=xlSortOnValues, Order:=xlAscending _
, DataOption:=xlSortNormal
.Sort.SetRange Range("A1:B" & lastrow)
.Sort.Header = xlGuess
.Sort.MatchCase = False
.Sort.Orientation = xlTopToBottom
.Sort.SortMethod = xlPinYin
.Sort.Apply
End With
'Return autocalulation and screen updates
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.Calculate
End Sub
See Error in finding last used cell in VBA for the best way to find the last row of data.
Find the last row and then change your range selection to:
Range("C1:C"&Trim(CStr(lastrow)))
To speed up your macro execution start your macro with:
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
and to restore autocalc and screen updates, end your macro with:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.Calculate