I am trying to sort data based on an unknown range.
When i try to sort based on 2 keys i get a Sort Method of Range Class failed
Option Explicit
Sub PostReview()
Dim tWb As ThisWorkbook, ws As Worksheet
Dim Lastrow As Integer, LastCol As Integer
Dim I As Integer, j As Integer
Dim rng As Range, rng2 As Range
Set ws = Worksheets("TR Query")
'Sort by Portfolio & Audit Date
Worksheets("TR Query").Activate
Lastrow = Cells(Rows.Count, 2).End(xlUp).Row
With ws
.Range("B1:B" & Lastrow).Copy
.Range("N:N").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
Set rng = Worksheets("TR Query").Range("N2:N" & Lastrow)
rng.Value = rng.Value
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
Set rng2 = .Range(.Cells(Lastrow, 1), .Cells(Lastrow, LastCol))
With rng2
.Cells.Sort Key1:=.Range("N1"), Order1:=xlAscending, _
Key2:=.Range("L1"), Order2:=xlDescending, _
Orientation:=xlTopToBottom, Header:=xlYes
End With
End With
i am hoping that the data is sorted first by column N from A to Z then sorted by column L from newest to oldest.
the error in my code is here:
With rng2
.Cells.Sort Key1:=.Range("N1"), Order1:=xlAscending, _ 'error happens here
Key2:=.Range("L1"), Order2:=xlDescending, _
Orientation:=xlTopToBottom, Header:=xlYes
End With
i'm not sure what i'm doing wrong.
Related
I have a number of sheets with VBA macros which transfer data after autofiltering.
When a sheet has no data after autofiltering, the macro brings up runtime error 1004 on the line
Workbooks("Predictology-Reports.xlsx").Sheets("FAL") _
.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Here is the full macro of one of them
Sub FALAYS()
Dim arr, ws As Worksheet, lc As Long, lr As Long
arr = Array("L.FAL_19_New_Summer2", "L.FA_FAL_3", "L.FAL_19_New_Summer")
Set ws = ActiveSheet
'range from A1 to last column header and last row
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
lr = ws.Cells.Find("*", after:=ws.Range("A1"), LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With ws.Range("A1", ws.Cells(lr, lc))
.HorizontalAlignment = xlCenter
.AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues
If .Rows.Count - 1 > 0 Then
On Error Resume Next
.Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
On Error GoTo 0
Else
Exit Sub
End If
End With
Workbooks("Predictology-Reports.xlsx").Sheets("FAL") _
.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End Sub
Try to set a range variable to the visible rows, then check to see if that got set before you copy/paste.
Sub FALAYS()
Dim arr, ws As Worksheet, lc As Long, lr As Long, rngCopy As Range
arr = Array("L.FAL_19_New_Summer2", "L.FA_FAL_3", "L.FAL_19_New_Summer")
Set ws = ActiveSheet
'range from A1 to last column header and last row
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
lr = ws.Cells.Find("*", after:=ws.Range("A1"), LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With ws.Range("A1", ws.Cells(lr, lc))
.HorizontalAlignment = xlCenter
.AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues
If .Rows.Count > 1 Then
On Error Resume Next
Set rngCopy = .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngCopy Is Nothing Then
rngCopy.Copy
Workbooks("Predictology-Reports.xlsx").Sheets("FAL") _
.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If 'have anything to copy
End If
End With
End Sub
If this is a common task then pull it out into its own Sub:
'given a [filtered] table rngTable, copy visible data rows as values to rngDestination
Sub CopyVisibleRows(rngTable As Range, rngDestination As Range)
Dim rngVis As Range
If rngTable.Rows.Count > 1 Then
On Error Resume Next
Set rngVis = rngTable.Offset(1, 0).Resize(rngTable.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngVis Is Nothing Then
rngVis.Copy
rngDestination.PasteSpecial xlPasteValues
End If
End If 'any source rows
End Sub
which reduces your original code to something like:
Sub FALAYS()
Dim arr, ws As Worksheet, lc As Long, lr As Long, tbl As Range
arr = Array("L.FAL_19_New_Summer2", "L.FA_FAL_3", "L.FAL_19_New_Summer")
Set ws = ActiveSheet
'range from A1 to last column header and last row
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
lr = ws.Cells.Find("*", after:=ws.Range("A1"), LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set tbl = ws.Range("A1", ws.Cells(lr, lc))
With tbl
.HorizontalAlignment = xlCenter
.AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues
If .Rows.Count > 1 Then
CopyVisibleRows tbl, Workbooks("Predictology-Reports.xlsx").Sheets("FAL") _
.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
End With
End Sub
There are a lot of improvements you could make to this code, but it should give you a starting point.
I'm assigning the filtered cells to a range, if there are cells, the range is "something".
Then copying the range to the sheet directly (you could skip the copy, paste method by transferring the values to the cells).
Tip: Try to avoid On Error Resume Next unless you know what you're doing and it is strictly necessary.
Read the comments and adjust the code to your needs.
EDIT: Added OERN as per Tim's suggestion
Code
Public Sub FALAYS()
Dim arrValues As Variant
arrValues = Array("L.FAL_19_New_Summer2", "L.FA_FAL_3", "L.FAL_19_New_Summer")
' Set the target workbook and sheet
Dim targetWorkbook As Workbook
Dim targetSheet As Worksheet
Set targetWorkbook = Workbooks("Predictology-Reports.xlsx")
Set targetSheet = targetWorkbook.Worksheets("FAL")
' Set the source sheet and range
Dim sourceSheet As Worksheet
Dim sourceRange As Range
Dim sourceColumn As Long
Dim sourceRow As Long
Set sourceSheet = ActiveSheet
'range from A1 to last column header and last row
sourceColumn = sourceSheet.Cells(1, sourceSheet.Columns.Count).End(xlToLeft).Column
sourceRow = sourceSheet.Cells.Find("*", after:=sourceSheet.Range("A1"), LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With sourceSheet.Range("A1", sourceSheet.Cells(sourceRow, sourceColumn))
.HorizontalAlignment = xlCenter
.AutoFilter Field:=1, Criteria1:=arrValues, Operator:=xlFilterValues
If .Rows.Count - 1 > 0 Then
' Set the cells to the source range
On Error Resume Next
Set sourceRange = .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error Goto 0
' Validate if the source range has cells
If Not sourceRange Is Nothing Then
sourceRange.Copy targetSheet.Range("A" & Rows.Count).End(xlUp).Offset(1)
Else
Exit Sub
End If
End If
End With
End Sub
Let me know if it works.
I am trying to put together a macro that finds a name in a column header then copies that column if the header matches.
It works the first time I run it but when the pasted column is deleted and the macro is run again I get a
Run-time Error 2004 Application-defined or Object-defined error
on this line:
Set sRange = Sheets("Data").Range("C1", Cells(1, LastCol))
Full code:
Sub Copy()
Dim Cell As Range, sRange As Range, Rng As Range
LastCol = Sheets("Data").Cells(1, Columns.Count).End(xlToLeft).Column
Set sRange = Sheets("Data").Range("C1", Cells(1, LastCol))
With sRange
Set Rng = .Find(What:="Chennai", _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not Rng Is Nothing Then
Lastrow = Sheets("Data").Cells(Rows.Count, Rng.Column).End(xlUp).Row
Sheets("Data").Range(Rng, Cells(Lastrow, Rng.Column)).Copy _
Destination:=Sheets("Summary").Range("A7")
End If
End With
End Sub
Can anyone see the issue?
Cells(1, LastCol)) has no worksheet specified. Therfore it is the same as ActiveSheet.Cells(1, LastCol)) and if Sheets("Data") is not the ActiveSheet this fails.
It should be
Set sRange = Worksheets("Data").Range("C1", Worksheets("Data").Cells(1, LastCol))
or even better
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Data")
Set sRange = ws.Range("C1", ws.Cells(1, LastCol))
Also I recommend to use Worksheets for worksheets as Sheets can also contain chart sheets etc.
Same problem in the end where Cells(Lastrow, Rng.Column) has no worksheet specified:
ws.Range(Rng, ws.Cells(Lastrow, Rng.Column)).Copy _
Destination:=Worksheets("Summary").Range("A7")
Make sure you never have a Cells, Range, Rows or Columns object without a worksheet specified. Or Excel might take the wrong worksheet.
In the end I would do something like (note that all variables should be declared, use Option Explicit:
Option Explicit
Public Sub Copy()
Dim wsSrc As Worksheet 'source worksheet
Set wsSrc = ThisWorkbook.Worksheets("Data")
Dim wsDest As Worksheet 'destination worksheet
Set wsDest = ThisWorkbook.Worksheets("Summary")
Dim LastCol As Long
LastCol = wsSrc.Cells(1, wsSrc.Columns.Count).End(xlToLeft).Column
Dim sRange As Range
Set sRange = wsSrc.Range("C1", wsSrc.Cells(1, LastCol))
Dim Rng As Range
Set Rng = sRange.Find(What:="Chennai", _
After:=sRange.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not Rng Is Nothing Then
Dim LastRow As Long
LastRow = wsSrc .Cells(wsSrc.Rows.Count, Rng.Column).End(xlUp).Row
wsSrc.Range(Rng, wsSrc.Cells(LastRow, Rng.Column)).Copy _
Destination:=wsDest.Range("A7")
End If
End Sub
I have an Excel file with many sheets, and I would like to filter old data at the end of the month and delete it. I can't always clear the data on the first, and sometimes users will work on the workbook before I can set it up for the current month.
This is the code I currently have:
Private Sub CommandButton4_Click()
Dim ws As Worksheet
Dim Rng As Range
Dim LastRow As Long, LastCol As Long
response = MsgBox("Tem a Certeza que quer Limpar todo os Dados?", vbYesNo)
If response = vbNo Then Exit Sub
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Formularios" Then
If ws.Name <> "Coordenador" Then
If ws.Name <> "LookupList" Then
With ws
.Unprotect Password:=pass
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Range("A" & .Columns.Count).End(xlToLeft).Column
Set Rng = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
With Rng
.AutoFilter Field:=1, Criteria1:=xlFilterLastMonth
.SpecialCells(xlCellTypeVisible).Offset(1, 0).Resize(.Rows.Count).Rows.Delete
End With
With ws
.AutoFilterMode = False
If .FilterMode = True Then
.ShowAllData
End If
.Protect Password:=pass
End With
End If
End If
End If
Next
End Sub
I get an Error 1004 object on this line:
.SpecialCells(xlCellTypeVisible).Offset(1, 0).Resize(.Rows.Count).Rows.Delete
This is the form I typically use.
With ws
.Unprotect Password:=pass
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .cells(1, .Columns.Count).End(xlToLeft).Column
Set Rng = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
With Rng
.AutoFilter Field:=1, Criteria1:=xlFilterLastMonth, Operator:=xlFilterDynamic
with .resize(.rows.count-1, .columns.count).offset(1, 0)
if cbool(application.subtotal(103, .cells)) then
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
end if
end with
End With
I changed the initial range (rng) to be only the second row and took out the offset and resize. Since the range is only used in this subroutine, why is it being resized?
I tested it with 5 or 6 dates in this month and last, even putting them out of order and it worked as expected.
sub stest()
With Worksheets(1)
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set Rng = .Range(.Cells(2, 1), .Cells(LastRow, 1))
End With
With Rng
.AutoFilter Field:=1, Criteria1:=xlFilterLastMonth, Operator:=xlFilterDynamic
.offset(1,0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
End Sub
I received data in column F,G,H, and I. I need to get that all into column E and take out the duplicates and the blank cells. The code i have so far works but it puts them all in the same row and doesn't keep them on their appropriate lines. I need them to stay on the same line they are currently in but to just transcribe over into the other column. This is what I have so far:
Sub Sample()
Dim ws As Worksheet
Dim LastRow As Long, lastCol As Long, i As Long
Dim Rng As Range, aCell As Range, delRange As Range '<~~ Added This
Dim MyCol As New Collection
~~> Change this to the relevant sheet name
Set ws = Sheets("Sheet1")
With ws
'~~> Get all the blank cells
Set delRange = .Cells.SpecialCells(xlCellTypeBlanks) '<~~ Added This
'~~> Delete the blank cells
If Not delRange Is Nothing Then delRange.Delete '<~~ Added This
LastRow = .Cells.Find(What:="*", After:=.Range("A1"), _
Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False).Row
lastCol = .Cells.Find(What:="*", After:=.Range("A1"), _
Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, MatchCase:=False).Column
Set Rng = .Range("A1:" & Split(.Cells(, lastCol).Address, "$")(1) & LastRow)
'Debug.Print Rng.Address
For Each aCell In Rng
If Not Len(Trim(aCell.Value)) = 0 Then
On Error Resume Next
MyCol.Add aCell.Value, """" & aCell.Value & """"
On Error GoTo 0
End If
Next
.Cells.ClearContents
For i = 1 To MyCol.Count
.Range("A" & i).Value = MyCol.Item(i)
Next i
'~~> OPTIONAL (In Case you want to sort the data)
.Columns(1).Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
End Sub
Try this.
Sub CopyThingy()
Dim wb As Workbook
Dim ws As Worksheet
Dim lCount As Long
Dim lCountMax As Long
Dim lECol As Long
Dim lsourceCol As Long
lECol = 5 '* E column
Set wb = ThisWorkbook
Set ws = wb.Sheets(1) '*Your Sheet
lCountMax = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
lsourceCol = 6
lCount = lCountMax
Do While lCount > 1
If ws.Cells(lCount, lsourceCol) <> "" Then
ws.Cells(lCount, lECol).Value = ws.Cells(lCount, lsourceCol).Value
End If
lCount = lCount - 1
Loop
lCountMax = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
lsourceCol = 7
lCount = lCountMax
Do While lCount > 1
If ws.Cells(lCount, lsourceCol) <> "" Then
ws.Cells(lCount, lECol).Value = ws.Cells(lCount, lsourceCol).Value
End If
lCount = lCount - 1
Loop
lCountMax = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
lsourceCol = 8
lCount = lCountMax
Do While lCount > 1
If ws.Cells(lCount, lsourceCol) <> "" Then
ws.Cells(lCount, lECol).Value = ws.Cells(lCount, lsourceCol).Value
End If
lCount = lCount - 1
Loop
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