I want to sort a column (it's a flagcolumn with Y/N). It should Toggle between ascending / descending on every click.
my code is not working..I am new to VBA. Any help please.
Private Sub CommandButton1_Click()
Dim xlSort As XlSortOrder
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row End With
If (Range("E2").Value > Range("E" & CStr(LastRow))) Then
xlSort = xlAscending
Else
xlSort = xlDescending
End If
.Sort Key1:=Range("E2"), Order1:=xlSort, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
ActiveWorkbook.Save
End Sub
This code worked for me:
Private Sub CommandButton1_Click()
Dim xlSort As XlSortOrder
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
If (.Range("E2").Value > .Range("E" & CStr(LastRow))) Then
xlSort = xlAscending
Else
xlSort = xlDescending
End If
.Range("E2:E" & LastRow).Sort Key1:=.Range("E2"), Order1:=xlSort, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
ActiveWorkbook.Save
End Sub
Hope this does the trick!!!
This will be easier if you declare a range variable ("rng" in the example below). This code should fix it.
Private Sub CommandButton1_Click()
Dim xlSort As XlSortOrder
Dim LastRow As Long
Dim rng As Range
With ActiveSheet
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
Set rng = Range("E2").Resize(LastRow, 1)
With rng
If (.Cells(1).Value > .Cells(LastRow - 1).Value) Then
xlSort = xlAscending
Else
xlSort = xlDescending
End If
.Sort Key1:=.Cells(1), Order1:=xlSort, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
End With
ActiveWorkbook.Save
End Sub
To sort ascending and descending with 2 keys
Sub Button1_Click()
Dim xlSort As XlSortOrder
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
If (.Range("E2").Value > .Range("E" & CStr(LastRow))) Then
xlSort = xlAscending
Else
xlSort = xlDescending
End If
.Range("E2:E" & LastRow).Sort Key1:=.Range("E2"), Order1:=xlSort, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
ActiveWorkbook.Save
End Sub
Related
I need to copy the last line of data, copy it with formulas to the row below it and then do a find and replace on the new last row - I got it to copy the line down but the find and replace isnt working - any tips? Thanks.
Sub CopyLastRowandReplace()
Dim sourceSheet As Worksheet
Dim sourceRange As Range
Dim LastRow As Long
Dim ReplaceRow As Range
Set sourceSheet = ThisWorkbook.Worksheets("Book 1")
LastRow = sourceSheet.Range("B" & sourceSheet.Rows.Count).End(xlUp).Row
Set sourceRange = sourceSheet.Range("B" & LastRow & ":N" & LastRow)
sourceRange.Offset(1).Formula = sourceRange.Formula
Set ReplaceRow = sourceSheet.Range("B" & LastRow & ":N" & LastRow)
Range("B" & LastRow & ":N" & LastRow).Select
Selection.Replace What:="Aug", Replacement:="Sep", LookAt:=xlFormulas, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
End Sub
Core problems
LookAt:=xlFormulas. Sould be xlPart or xlWhole
You are not Replacing in the New last row (you haven't updated LastRow)
That said, there are other oportunities for improvement too
Sub Demo()
CopyLastRowandReplace ThisWorkbook.Worksheets("Book 1"), 2, 13, "Aug", "Sep"
End Sub
Sub CopyLastRowandReplace(sourceSheet As Worksheet, StartColumn As Long, NumColumns As Long, FindValue As Variant, ReplaceValue As Variant)
Dim sourceRange As Range
Set sourceRange = sourceSheet.Cells(sourceSheet.Rows.Count, StartColumn).End(xlUp).Resize(1, NumColumns)
With sourceRange
.Offset(1, 0).Formula = .Formula
.Offset(1, 0).Replace _
What:=FindValue, _
Replacement:=ReplaceValue, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=True, _
SearchFormat:=False, _
ReplaceFormat:=False
End With
End Sub
I am trying to compare two columns in one workbook and based on a certain condition copy the row where that condition is met to another workbook.
This is for a "database" I am working on. I have a Master sheet and then several versions of sub-masters that are catered specifically to certain individuals.
I have tried to some success by creating two different With statements and using a delete function on the sub-sheet but it is clunky and I'm not a fan of it. Please see the example code below.
Public Sub Workbook_Open()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long
Dim strSearch As String
Dim vrtSelectedItem As Variant
Set wb1 = Application.Workbooks.Open("C:\Users\myfolder\Desktop\Excel Master Test\ROLE BASED TRACKER DRAFT.xlsx")
Set ws1 = wb1.Worksheets("Master")
Set wb2 = ThisWorkbook
Set ws2 = wb2.Worksheets("Sheet1")
'~~> Specifies which resources info. you are retrieving
strSearch = "117"
ws2.Cells.Clear
'~~> Copying the header information and formatting.
ws1.Range("1:1").Copy
ws2.Range("1:1").PasteSpecial
With ws1
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("L1:L" & lRow)
.AutoFilter Field:=1, Criteria1:=strSearch
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
.AutoFilterMode = False
End With
'~~> Destination File
With ws2
If Application.WorksheetFunction.CountA(.Rows) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row + 1
Else
lRow = .Range("A" & Rows.Count).End(xlUp).Row
End If
copyFrom.Copy .Rows(lRow)
End With
With ws2
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("AD1:AD" & lRow)
.AutoFilter Field:=1, Criteria1:=strSearch
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
.AutoFilterMode = False
End With
With ws1
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("AD1:AD" & lRow)
.AutoFilter Field:=1, Criteria1:=strSearch
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
.AutoFilterMode = False
End With
'~~> Destination File
With ws2
If Application.WorksheetFunction.CountA(.Rows) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row + 1
Else
lRow = .Range("A" & Rows.Count).End(xlUp).Row
End If
copyFrom.Copy .Rows(lRow)
End With
With ws2.Sort
.SetRange Range("A2:A12000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
wb1.Save
wb1.Close
wb2.Save
End Sub
This is the code that I am trying to get work. I keep getting a Type Mismatch error on my cell comparison lines. '' If ws1.Range("AD1:AD" & lRow) <> ws1.Range("L1:L" & lRow) Then ''
Public Sub Workbook_Open()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long
Dim strSearch As String
Dim vrtSelectedItem As Variant
Set wb1 = Application.Workbooks.Open("C:\Users\myfolder\Desktop\Excel Master Test\ROLE BASED TRACKER DRAFT.xlsx")
Set ws1 = wb1.Worksheets("Master")
Set wb2 = ThisWorkbook
Set ws2 = wb2.Worksheets("Sheet1")
'~~> Specifies which resources info. you are retrieving
strSearch = "117"
ws2.Cells.Clear
'~~> Copying the header information and formatting.
ws1.Range("1:1").Copy
ws2.Range("1:1").PasteSpecial
With ws1
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
If ws1.Range("AD1:AD" & lRow) <> ws1.Range("L1:L" & lRow) Then
With .Range("AD1:AD" & lRow)
.AutoFilter Field:=1, Criteria1:=strSearch
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
.AutoFilterMode = False
End If
End With
'~~> Destination File
With ws2
If Application.WorksheetFunction.CountA(.Rows) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row + 1
Else
lRow = .Range("A" & Rows.Count).End(xlUp).Row
End If
copyFrom.Copy .Rows(lRow)
End With
With ws1
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
If ws1.Range("AD1:AD" & lRow) = ws1.Range("L1:L" & lRow) Then
With .Range("L1:L" & lRow)
.AutoFilter Field:=1, Criteria1:=strSearch
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
.AutoFilterMode = False
End If
End With
'~~> Destination File
With ws2
If Application.WorksheetFunction.CountA(.Rows) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row + 1
Else
lRow = .Range("A" & Rows.Count).End(xlUp).Row
End If
copyFrom.Copy .Rows(lRow)
End With
With ws2.Sort
.SetRange Range("A2:A12000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
wb1.Save
wb1.Close
' wb2.Save
End Sub
I just wanted to thank everyone who helped. I am going to just stick with my initial solution of filter, copy, paste, filter, delete, filter, copy, paste, sort.
See my first code block for what I am talking about. Cheers.
I am trying to sort my records based on Col A values, there are 5 different values and many rows (in a table). Also I have the custom list created in excels built in sort feature.
I am getting an error Sort method of range class failed on
oRangeSort.Sort Key1:=oRangeKey, Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=Application.CustomListCount + 1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Here is my code:
Sub Sort()
Dim oWorksheet As Worksheet
Set oWorksheet = ActiveWorkbook.Worksheets("database")
Dim oRangeSort As Range
Dim oRangeKey As Range
' one range that includes all colums do sort
Set oRangeSort = oWorksheet.Range("A2:FR20000")
' start of column with keys to sort
Set oRangeKey = oWorksheet.Range("A2")
' custom sort order
Dim sCustomList(1 To 5) As String
sCustomList(1) = "sort1"
sCustomList(2) = "sort2"
sCustomList(3) = "sort3"
sCustomList(4) = "sort4"
sCustomList(5) = "sort5"
Application.AddCustomList ListArray:=sCustomList
oWorksheet.Sort.SortFields.Clear
oRangeSort.Sort Key1:=oRangeKey, Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=Application.CustomListCount + 1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
' clean up
ActiveSheet.Sort.SortFields.Clear
Application.DeleteCustomList Application.CustomListCount
Set oWorksheet = Nothing
End Sub
Try a VBA sort as opposed to rewriting the recorded sort code.
Sub custom_sort()
Dim vCustom_Sort As Variant, rr As Long
vCustom_Sort = Array("sort1", "sort2", "sort3", "sort4", "sort5")
Application.AddCustomList ListArray:=vCustom_Sort
With ActiveWorkbook.Worksheets("database")
.Sort.SortFields.Clear
rr = .Cells(.Rows.Count, "A").End(xlUp).Row
With .Range("A2:FR" & rr)
.Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, DataOption1:=xlSortNormal, _
Orientation:=xlTopToBottom, Header:=xlYes, MatchCase:=False, _
OrderCustom:=Application.CustomListCount + 1
End With
.Sort.SortFields.Clear
End With
End Sub
Sorry about the flury of posting, I am trying to finish a project (there always seems to be one more thing)
I am tring to auto sort to last column starting at F2 I have the following but is not working
Thanks
Sub Sort()
Dim lastRow As Long
Dim lastCol As Long
Dim ws As Worksheet
Set ws = Sheets("sheet1")
lastRow = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
lastCol = Cells(2, ws.Columns.Count).End(xlToLeft).Column
With Sheets("Sheet1")
ws.Range(ws.Range("F2"), ws.Cells(lastRow, lastCol)).Sort _
Key1:=Range("lastCol"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
End Sub
The value for Key1 must be a range. You are trying to use the number that is the last column, and that won't work even if you remove the quotation marks.
Replace Key1:=Range("lastCol")
with Key1:=Cells(2, lastCol)
Note that you can use the GetColumnLetter function I included in my previous answer to get the letter for the lastCol column. If you have the letter, you can use this syntax instead of the Cells version:
Key1:=Range(myCol & 2)
To make sure you know what you are sorting, you can add a little bit of debugging code. You can also use the Immediate window and the Watch window to figure this out.
Replace your entire sub with this:
Sub Sort()
Dim lastRow As Long
Dim lastCol As Long
Dim ws As Worksheet
Dim rng As Range
Dim sortRng As Range
Set ws = Sheets("sheet1")
lastRow = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
lastCol = Cells(2, ws.Columns.Count).End(xlToLeft).Column
Set rng = ws.Range(ws.Range("F2"), ws.Cells(lastRow, lastCol))
Set sortRng = ws.Cells(lastRow, lastCol)
MsgBox "I will sort this range: " & rng.Address & _
" using this column: " & sortRng
rng.Sort Key1:=sortRng, Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub
Following is the code to fetch the data from the last column of each sheet and display it in the sheet "MainSheet". Since the last column has merged cells this code also deletes the cells in between
This code displays the data as verical view in the MainSheet and I want to make it horizontal i.e data from the last column of each sheet should be fetched to the rows in the MainSheet and also the merged cells should be taken care of
Sub CopyLastColumns()
Dim cnt As Integer, sht As Worksheet, mainsht As Worksheet, col As Integer, rw As Integer
ActiveSheet.Name = "MainSheet"
Set mainsht = Worksheets("MainSheet")
cnt = 1
For Each sht In Worksheets
If sht.Name <> "MainSheet" Then
sht.Columns(sht.Range("A1").CurrentRegion.Columns.Count).Copy
mainsht.Columns(cnt).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
mainsht.Cells(150, cnt) = sht.Range("A2")
cnt = cnt + 1
End If
Next sht
With mainsht
For col = 1 To cnt
For rw = .Cells(65536, col).End(xlUp).row To 1 Step -1
If .Cells(rw, col) = "" Then
.Cells(rw, col).Delete Shift:=xlUp
End If
Next rw
Next col
End With
End Sub
Thanks in advance
This code copies the last column from every sheet and pastes them as rows in the MainSheet keeping the merged cells intact.
Option Explicit
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim wsOLrow As Long, wsILrow As Long, wsILcol As Long
On Error GoTo Whoa
Application.ScreenUpdating = False
Set wsO = Sheets("MainSheet")
wsOLrow = wsO.Cells.Find(What:="*", _
After:=wsO.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row + 1
For Each wsI In ThisWorkbook.Sheets
If wsI.Name <> wsO.Name Then
With wsI
wsILrow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
wsILcol = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
.Range(Split(Cells(, wsILcol).Address, "$")(1) & "1:" & _
Split(Cells(, wsILcol).Address, "$")(1) & _
wsILrow).Copy .Range(Split(Cells(, wsILcol + 1).Address, "$")(1) & "1:" & _
Split(Cells(, wsILcol + 1).Address, "$")(1) & wsILrow)
.Activate
With .Range(Split(Cells(, wsILcol + 1).Address, "$")(1) & "1:" & _
Split(Cells(, wsILcol + 1).Address, "$")(1) & wsILrow)
.UnMerge
.Cells.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
End With
wsILrow = .Range(Split(Cells(, wsILcol).Address, "$")(1) & Rows.Count).End(xlUp).Row
With .Range(Split(Cells(, wsILcol + 1).Address, "$")(1) & "1:" & _
Split(Cells(, wsILcol + 1).Address, "$")(1) & wsILrow)
.Copy
wsO.Cells(wsOLrow, 1).PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
.Delete
End With
wsOLrow = wsOLrow + 1
End With
End If
Next
LetsContinue:
Application.ScreenUpdating = True
MsgBox "Done"
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub