My code is sorting the Column A Numerically correctly and also info tied to it in column B-D but not Columns E-M which are qty values. So when I add a Stock # the Description, supplier and Part # all sort with the Stock #, but not any qty values. They just stay in the same row. I have data that needs to stay with the sorted stock # until Column X.
Sub Sorting()
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Set sht = Sheet1
Set StartCell = Range("A9")
'Refresh UsedRange
Worksheets("Order Summary").UsedRange
'Find Last Row
LastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Select Range
sht.Range("A9:A" & LastRow).Select
Range("A9:A" & LastRow).Sort _
Key1:=Range("A9"), Header:=xlYes
End Sub
Sub Sorting()
Application.ScreenUpdating = False
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range("A9")
ActiveSheet.Sort.SetRange Range("A9:X500")
ActiveSheet.Sort.Apply
Application.ScreenUpdating = True
End Sub
Related
I have a VBA code that finds the last row of data in a column and selects all the data. My data has a break a third of the way down where an empty row is placed. I want to be able to find the last row of data before the break and not include the data that is in the same column after the break. Is there a way to do this?
Thanks!
Sub Resort()
Dim ws As Worksheet
Set ws = Worksheets("Workbench Report")
lastrow = ws.Cells(ws.Rows.count, "E").End(xlUp).Row
ws.Select
ws.Range("B2:B" & lastrow).Select
ws.Columns("B:G").Sort key1:=ws.Range("E1"), order1:=xlAscending, Header:=xlYes, Orientation:=xlSortColumns
ws.Select
ws.Range("E2").Select
End Sub
Use the .End function on the cell. This should select the range you want.
Range(Cells(2, "B"), Cells(Cells(2, "E").End(xlDown).row, "G")).Select
I assume you are looking to sort only the rows above the break, so the following should do the trick.
Sub Resort()
Dim ws As Worksheet
Set ws = Worksheets("Workbench Report")
ws.Range(Cells(2, "B"), Cells(Cells(2, "E").End(xlDown).row, "G")).Select
Selection.Sort key1:=ws.Range("E1"), order1:=xlAscending, Header:=xlYes, Orientation:=xlSortColumns
End Sub
Granted you could also make this a one liner
Sub Resort()
Dim ws As Worksheet
Set ws = Worksheets("Workbench Report")
ws.Range(Cells(2, "B"), Cells(Cells(2, "E").End(xlDown).row, "G")).Sort _
key1:=ws.Range("E1"), order1:=xlAscending, Header:=xlYes, Orientation:=xlSortColumns
End Sub
lastrow = lastRowOfRange(range("b2").currentregion)
Function lastRowOfRange(rng As Range)
Dim adr
adr = Split(rng.Address, "$")
lastRowOfRange = adr(UBound(adr))
End Function
You could also use
lastrow = rngLastCell(range("b2").CurrentRegion).row
Function rngLastCell(rng As Range) As Range
'returns the last cell of a range
Set rngLastCell = rng.Cells(0, 0).Offset(rng.Rows.Count, rng.Columns.Count)
End Function
I have a combo box with a value that I would like to be searched for in another workbook column. The code using autofilter then returns the rows which have that value in the same column(column 4).
It works correctly however the first row of the source is always being copied over to the destination, weather it does or doesn't not have the value being looking for in the specific column.
The offset or cell shifting is being used as the first two row in both sheets are headers
Sub CommandButton1_Click()
'Look in data repository for the Combobox filter value and only return those associated rows (can be more than one)
Dim DataBlock As Range, Dest As Range
Dim LastRow As Long, LastCol As Long
Dim SheetOne As Worksheet, SheetTwo As Worksheet
Dim PN As String
PN = ComboBox1.Value
'set references up-front
Set SheetTwo = ThisWorkbook.Worksheets("Report") 'this is the expiditing report
Set SheetOne = Workbooks.Open("C:\Users\Colin\Documents\Nexen\Data Repository V1.xlsm").Sheets("Data") 'this is the expiditing report
Set Dest = SheetTwo.Cells(3, 1) '<~ this is where we'll put the filtered data
'identify the "data block" range, which is where
'the rectangle of information that Ill apply
'.autofilter to
With SheetOne
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
Set DataBlock = .Range(.Cells(3, 1), .Cells(LastRow, LastCol))
'Set DataBlock = Range("A3:AV65000") 'for testing
End With
'apply the autofilter to column D (i.e. column 4)
With DataBlock
'can use offset .Offset(2, 0).
.AutoFilter Field:=4, Criteria1:=PN
'copy the still-visible cells to sheet 2
.SpecialCells(xlCellTypeVisible).Copy Destination:=Dest
End With
'turn off the autofilter
With SheetOne
.AutoFilterMode = False
If .FilterMode = True Then .ShowAllData
End With
End Sub
Sub CommandButton2_Click()
Dim MyBook As String
Dim MyRange As Range
'Get name of current wb
MyBook = ThisWorkbook.Name
Set MyRange = MyBook.Sheets("Report").Range("T3,AC65000")
'ActiveWorkbook.Close savechanges:=True
MyBook.Activate
End Sub
![etr][1]
So why am i getting the first row back regardless? I have tried a multitude of things.
Your .Range needs to be in a Table with a header for AutoFilter to work properly.
I have a sheet where in Col A there is a String A and Col B consists of String B.
I want to keep rows with the Word 'Begründung' in Col A and 'Nein' in Col B.
I am using the following code found from these sources Efficient way to delete entire row if cell doesn't contain '#' & Delete Row based on Search Key VBA
Sub KeepOnlyAtSymbolRows()
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Set ws = ActiveWorkbook.Sheets("Sheet1")
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("A1:A" & lastRow)
' filter and delete all but header row
With rng
.AutoFilter Field:=1, Criteria1:="<>*Begründung*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
' turn off the filters
ws.AutoFilterMode = False
End Sub
I want to add another criteria for the Col B. Wherever in Col B 'Nein' is encountered that row is kept and the rest is deleted but at the same time 'Begrüundung in Col A is kept and the rest is deleted.
In other words wherever the words 'Begründung' and 'Nein' is encountered in the sheet those rows are kept and the rest is deleted.
I would really be grateful if any of you could help.
Try this:
Sub DeleteWithMultipleColumnsCriterias()
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Set ws = ActiveWorkbook.Sheets("Sheet1")
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("A1:B" & lastRow)
' filter and delete all but header row
With rng
.AutoFilter Field:=1, Criteria1:="<>*Begründung*"
.AutoFilter Field:=2, Criteria1:="<>*Nein*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
' turn off the filters
ws.AutoFilterMode = False
End Sub
I've written some simple code that matches cells in one worksheet to cells in another, and then deletes the entire row if the cells are equal.
The code selects rows properly, but for some reason refuses to actually delete the rows in my worksheet. EDIT: Some of the rows delete. Others don't, even though they have the exact same values as those that did delete. If anyone can help that would be greatly appreciated.
Sub delFunds()
Dim fCell As Range 'Fund cell
Dim fRng As Range 'Fund range
Dim wCell As Range 'Working sheet cell
Dim wRng As Range 'Working sheet range
Dim n As Long
Set fRng = Worksheets("Funds").Range("C2:C117")
Set wRng = Worksheets("Working sheet").Range("I3:I7483")
For Each fCell In fRng.Cells 'Loop through all funds
For Each wCell In wRng.Cells 'Loop through all working cells
If StrComp(wCell.Value, fCell.Value, vbTextCompare) = 0 Then 'If equal then delete
n = wCell.Row
Rows(n & ":" & n).Select
Selection.Delete Shift:=xlUp
End If
Next wCell
Next fCell 'Go to next fund
End Sub
I would use this code without nested loop:
Sub delFunds()
Dim rngToDel As Range
Dim fRng As Range 'Fund range
Dim wCell As Range 'Working sheet cell
Dim wRng As Range 'Working sheet range
Set fRng = Worksheets("Funds").Range("C2:C117")
Set wRng = Worksheets("Working sheet").Range("I3:I7483")
For Each wCell In wRng 'Loop through all working cells
' if wCell found in Fund range then delete row
If Not IsError(Application.Match(Trim(wCell.Value), fRng, 0)) Then
If rngToDel Is Nothing Then
Set rngToDel = wCell
Else
Set rngToDel = Union(rngToDel, wCell)
End If
End If
Next wCell
If Not rngToDel Is Nothing Then rngToDel.EntireRow.Delete
End Sub
I know #simoco's answer works and has been accepted already, but I love a good question so I wanted to pull together a solution using the autofilter to kill big swaths of the working sheet at once. I figured your design might look like this:
From there, you can loop through the concise fund list and filter the working sheet on each fund:
Option Explicit
Sub EliminateWorkingDuplicates()
Dim WorkingSheet As Worksheet, FundSheet As Worksheet
Dim FundRange As Range, WorkingRange As Range, _
Fund As Range
Dim LastRow As Long, LastCol As Long, _
WorkingFundCol As Long
'assign sheets and ranges for easy reference
Set WorkingSheet = ThisWorkbook.Worksheets("Working sheet")
Set FundSheet = ThisWorkbook.Worksheets("Funds")
Set FundRange = FundSheet.Range("C2:C117")
WorkingFundCol = 9 'column I on working sheet
'determine the bounds of the data block on the working sheet
LastRow = WorkingSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastCol = WorkingSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set WorkingRange = Range(WorkingSheet.Cells(2, 1), WorkingSheet.Cells(LastRow, LastCol))
'start working through the funds and calling the autofilter function
For Each Fund In FundRange
Call FilterAndDeleteData(WorkingRange, WorkingFundCol, Fund.Value)
Call ClearAllFilters(WorkingSheet)
Next Fund
End Sub
'**********
'blow away rows
Sub FilterAndDeleteData(DataBlock As Range, TargetColumn As Long, Criteria As String)
'make sure some joker didn't pass in an empty range
If DataBlock Is Nothing Then Exit Sub
'execute the autofilter with the supplied column and criteria
With DataBlock
.AutoFilter Field:=TargetColumn, Criteria1:=Criteria
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
End Sub
'**********
'safely clear filters
Sub ClearAllFilters(TargetSheet As Worksheet)
With TargetSheet
.AutoFilterMode = False
If .FilterMode = True Then
.ShowAllData
End If
End With
End Sub
I want to do two successive filtering; the first on dates which I use auto-filter and on the produced result I want to do advance-filter (because I have OR in mind).
So what I did first was to set a range variable to the unfiltered range.
Set rng = Range(ws.Cells(1, 1), ws.Cells(rowNos, colNos))
Then using auto-filter I filter for given dates.
rng.AutoFilter Field:=1, Criteria1:=">" & lDate
Since now some rows will be hidden, and I want to apply advanced filter, I made use of specialcells
rng.SpecialCells(xlCellTypeVisible).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=crt, CopyToRange:=thisWB.Worksheets("Sheet3").Range("A1"), _
Unique:=False
However I got an error in the last step "the command requires at least two rowa of data . . " I made sure that there were at least 100 rows which fit the criteria meaning that the error is not because of a lack of rows.
Please help me get the problem. Also if there's another way I can accomplish the task I'll be happy to change my codes. What I'm trying to do is for specific dates filter a table and then filter again for values on two columns (as is normally done with advanced filters).
It seems like .AdvancedFilter does not work on non-continuous ranges. The code below is a bit kludge-y, but worked for a little example I pulled together where I want to return observations that are > April 1st, 2014 where Foo = Yes and Bar = 7. My data sheet contains exactly one row that matches all those criteria.
Option Explicit
Sub FilterTwice()
Dim DataSheet As Worksheet, TargetSheet As Worksheet, _
ControlSheet As Worksheet, TempSheet As Worksheet
Dim DataRng As Range, ControlRng As Range, _
TempRng As Range
Dim lDate As Date
Dim LastRow As Long, LastCol As Long
'assign sheets for easy reference
Set DataSheet = ThisWorkbook.Worksheets("Sheet1")
Set ControlSheet = ThisWorkbook.Worksheets("Sheet2")
Set TargetSheet = ThisWorkbook.Worksheets("Sheet3")
'clear any previously-set filters
Call ClearAllFilters(DataSheet)
'assign data range
LastRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set DataRng = Range(DataSheet.Cells(1, 1), DataSheet.Cells(LastRow, LastCol))
'assign a control (or critieria) range for the advanced filter
Set ControlRng = Range(ControlSheet.Cells(1, 1), ControlSheet.Cells(2, 2))
'apply date filter
lDate = "4/1/2014"
With DataRng
.AutoFilter Field:=1, Criteria1:=">" & lDate
End With
'add a temporary sheet and copy the visible cells to create a continuous range
Set TempSheet = Worksheets.Add
DataRng.SpecialCells(xlCellTypeVisible).Copy
TempSheet.Range("A1").PasteSpecial Paste:=xlPasteAll
'assign temp range
LastRow = TempSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastCol = TempSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set TempRng = Range(TempSheet.Cells(1, 1), TempSheet.Cells(LastRow, LastCol))
'apply advanced filter to temp range and get obs where foo = yes and bar = 7
With TempRng
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=ControlRng, _
CopyToRange:=TargetSheet.Range("A1"), Unique:=False
End With
'remove the temp sheet and clear filters on the data sheet
Application.DisplayAlerts = False
TempSheet.Delete
Application.DisplayAlerts = True
DataSheet.AutoFilterMode = False
End Sub
Sub ClearAllFilters(cafSheet As Worksheet)
With cafSheet
.AutoFilterMode = False
If .FilterMode = True Then
.ShowAllData
End If
End With
End Sub