I am writing a subroutine to dynamically copy 2 columns from one sheet to another. These column lengths might change from one report to another.
Here is the code:
Sub getAnalystsCount()
Dim rng As Range
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Dim varray As Variant, element As Variant
Set ws = ThisWorkbook.Worksheets("ReportData")
With ws
Worksheets("ReportData").Activate
Columns("E:E").Select
ActiveWorkbook.Worksheets("ReportData").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ReportData").AutoFilter.Sort.SortFields.Add Key:= _
Range("E1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("ReportData").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set First row
firstrow = 2
'~~> Set your range
Set rng = .Range("E" & firstrow & ":E" & lastrow)
varray = rng.Value
'Generate unique list and count
For Each element In varray
If dict.Exists(element) Then
dict.Item(element) = dict.Item(element) + 1
Else
dict.Add element, 1
End If
Next
End With
Set ws = ThisWorkbook.Worksheets("Analysts")
With ws
Worksheets("Analysts").Activate
'Paste report somewhere
ws.Range("A3").Resize(dict.Count, 1).Value = _
WorksheetFunction.Transpose(dict.Keys)
ws.Range("B3").Resize(dict.Count, 1).Value = _
WorksheetFunction.Transpose(dict.Items)
......
the error is in this line:
ActiveWorkbook.Worksheets("ReportData").AutoFilter.Sort.SortFields.Clear
Replace your below code
Columns("E:E").Select
ActiveWorkbook.Worksheets("ReportData").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ReportData").AutoFilter.Sort.SortFields.Add Key:= _
Range("E1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("ReportData").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With the below code
Columns("E:E").Select
lastrow1 = .Range("E" & .Rows.Count).End(xlUp).Row
ActiveWorkbook.Worksheets("ReportData").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ReportData").Sort.SortFields.Add Key:=Range("E1") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("ReportData").Sort
.SetRange Range("E2:E" & lastrow1)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
startCell = Range("A1").Address
endCell = Range("E100000").End(xlUp).Address
ActiveWorkbook.Worksheets("ReportData").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ReportData").Sort.SortFields.Add Key:=Range("E1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("ReportData").Sort
.SetRange Range(startCell,endCell)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Obviously this is rough, you will need to make it your own, but it will allow you to sort the E column which is what your initial code looks like it was trying to do.
The Range.Sort method can be used for a quick one column sort and discards much of the verbose code produced when recording a worksheet sort operation. Without an active AutoFilter, this is the better way to go.
Sub getAnalystsCount()
Dim el As Long, ws As Worksheet
Dim dict As Object
Dim varray As Variant
Set dict = CreateObject("scripting.dictionary")
'don't know what is in column E but this might be helpful
'dict.comparemode = vbTextCompare 'non-case-sensitive
Set ws = ThisWorkbook.Worksheets("ReportData")
With ws
'this is not necessary inside a With ... End With block
'Worksheets("ReportData").Activate
With .Range("A1").CurrentRegion
'this quick code line is all you need
.Cells.Sort Key1:=.Columns(5), Order1:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlYes
'resize to # of rows -1 × 1 column and shift 1 row down and over to column E
With .Resize(.Rows.Count - 1, 1).Offset(1, 4)
'store the raw values
varray = .Value2
End With
End With
End With 'done with the ReportData worksheet
'Generate unique list and count
'I prefer to work with LBound and UBound
For el = LBound(varray, 1) To UBound(varray, 1)
If dict.Exists(varray(el, 1)) Then
dict.Item(varray(el, 1)) = dict.Item(varray(el, 1)) + 1
Else
dict.Add Key:=varray(el, 1), Item:=1
End If
Next el
Set ws = ThisWorkbook.Worksheets("Analysts")
With ws
'this is not necessary inside a With ... End With block
'Worksheets("Analysts").Activate
'might want to clear the destination cell contents first if there is something there
if application.counta(.Range("A3:B3") = 2 then _
.Range("A3:B" & .Cells(Rows.Count, "B").End(xlUp).Row).ClearContents
'Paste report somewhere
.Range("A3").Resize(dict.Count, 1).Value = _
WorksheetFunction.Transpose(dict.Keys)
.Range("B3").Resize(dict.Count, 1).Value = _
WorksheetFunction.Transpose(dict.Items)
End With 'done with the Analysts worksheet
End Sub
I prefer to work with the LBound and UBound functions to determine the scope of an array.
When you are inside a With ... End With statement, use the . to note the parent worksheet and discard the Range .Activate method and ws variable.
Related
I'm having a hard time trying to sort my columns. Should seem like an easy fix but I keep getting stuck. My columns are set up so that when it first populates, Column A might have values in row 3 6 9 12, Column B might have values in 1 2 3 4 and C might have values in 10 20 and 30. I'm trying to go from Column A to Column C and recursively sorting it alphabetically. I have hardcoded as a sub but everytime it gets to a column without values it ends the the program entirely. This is what I have so far
ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Add Key:= _
Range("G1:G3000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Add Key:= _
Range("H1:H3000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Add Key:= _
Range("I1:I3000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Add Key:= _
Range("J1:J3000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
I'm calling the function on two sheets. On sheet 1 it has values up to J but on sheet 2 it only has values up to I and it gets stuck giving me an error on Sheet 2 because theres nothing on J. How couple I incorporate a for loop and how would my program know if there is/is not a value in the next column?
Column A Column B Column C Column D Column E
Row 1 Bread Fruit
Row 2 Apple OJ Coffee
Row 3 Banana Bread Lotion Water
Row 4 Soda
Row 5 Fruit Coke
Row 6 Coffee Tea
Based on your description, something like this might work for you:
Sub tgr()
Dim wb As Workbook
Dim ws As Worksheet
Dim i As Long
Set wb = ActiveWorkbook
For Each ws In wb.Sheets
Select Case ws.Name
Case "Sheet1", "Sheet2"
For i = ws.Columns("A").Column To ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
With ws.Range(ws.Cells(1, i), ws.Cells(ws.Rows.Count, i).End(xlUp))
If .Cells.Count > 1 Then
.Sort .Cells, xlAscending, Header:=xlYes
End If
End With
Next i
End Select
Next ws
End Sub
EDIT:
If your data doesn't actually have headers, try this instead:
Sub tgr()
Dim wb As Workbook
Dim ws As Worksheet
Dim rLast As Range
Dim i As Long
Set wb = ActiveWorkbook
For Each ws In wb.Sheets
Select Case ws.Name
Case "Sheet1", "Sheet2"
On Error Resume Next
Set rLast = ws.Cells.Find("*", ws.Range("A1"), xlFormulas, , xlByColumns, xlPrevious)
On Error GoTo 0
If Not rLast Is Nothing Then
For i = ws.Columns("A").Column To rLast.Column
With ws.Range(ws.Cells(1, i), ws.Cells(ws.Rows.Count, i).End(xlUp))
If .Cells.Count > 1 Then .Sort .Cells, xlAscending, Header:=xlYes
End With
Next i
End If
End Select
Next ws
End Sub
I am trying to automate a report generation process in excel.
So, let me give you guys a background:-
I have 3 columns in my datasheet:
Column A is manufacturing location
Column B is Vehicle line
Column C is Progress Update
I trying to generate a report which merges and centers MFG Locations in Column A and the same time Merge and Centers Vehicle lines in that plant with Column B
I am attaching a sample of the output I need. As of now , I am manually doing this process, I hope someone can guide me with automating this process
This code will help you what you have asked.
Sub MergeSameCells()
Dim Rng As Range
Dim xRows, lastRow As Integer
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:C" & lastRow).Select
With ActiveWorkbook.ActiveSheet.Sort
With .SortFields
.Clear
.Add Key:=Range("A2:A" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add Key:=Range("B2:B" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add Key:=Range("C2:C" & lastRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
End With
.SetRange Range("A2:C" & lastRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Set WorkRng = Range("A2:B" & lastRow)
xRows = WorkRng.Rows.Count
If WorkRng Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Rng In WorkRng.Columns
For i = 1 To xRows - 1
For j = i + 1 To xRows
If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
Exit For
End If
Next
WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge
i = j - 1
Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Try and let me know if it works.
I would like to sort Columns E though "lastColumn" in ascending order.
The values to be used for sorting are in Row 14.
The data set is located in cells E8 to "lastColumn" "lastRow".
Below is what I have thus far, but I am getting an error that the reference is not valid. I'm guessing I am not using &lastRow& correctly, let alone trying to plug in the value for "lastColumn".
I am using lastColumn and lastRow as a means to ignore blank cells.
Sub SortColumns()
Dim lastColumn As Long
Dim lastRow As Long
lastColumn = Sheet1.Cells(8, Columns.Count).End(xlToLeft).Column
lastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range( _
"E14:Z" & lastRow&), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.ActiveSheet.Sort
.SetRange Range("E8:I" & lastRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
End Sub
I think you only had a small mistake. I added a little more code as you should always be specific on which workbook and on which sheet you are working. Try this:
Dim lastColumn As Long
Dim lastRow As Long
Dim Sht1 As Worksheet
Sht1 = ActiveWorkbook.Sheets("Sheet1")
lastColumn = Sht1.Cells(8, Sht1.Columns.Count).End(xlToLeft).Column
lastRow = Sht1.Cells(Sht1.Rows.Count, 1).End(xlUp).Row
Sht1.Sort.SortFields.Clear
Sht1.Sort.SortFields.Add Key:=Range( _
"E14:Z" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sht1.Sort
.SetRange Range("E8:I" & lastRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
I have many worksheets with sequential linear xy data that vary in length. The objective is to delete all rows where x data is not divisible by 50. Below is the generated macro that uses a helper column to search for integers to be deleted.
Sub Divis50()
Sheets("VERT SCALES").Select
Range("C2").Select
ActiveCell.FormulaR1C1 = _
"=IF((OR((RIGHT(RC[-2],2)=""50""),(RIGHT(RC[-2],2)=""00""))),""YES"",""NO"")"
Range("C2").Select
Selection.AutoFill Destination:=Range("C2:C6062")
'sort filtered results
Range("C2").Select
ActiveWorkbook.Worksheets("VERT SCALES").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("VERT SCALES").Sort.SortFields.Add Key:=Range("C2") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("VERT SCALES").Sort
.SetRange Range("A2:C6062")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' scroll to first no and delete rows
Rows("123:123").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
'sort "A" back to consecutive numbers
Range("A2").Select
ActiveWorkbook.Worksheets("VERT SCALES").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("VERT SCALES").Sort.SortFields.Add Key:=Range("A2") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("VERT SCALES").Sort
.SetRange Range("A2:C122")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'delete filtered column
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
End Sub
This will delete rows that don't equal a whole number when divided by 50
Sub Button1_Click()
Dim FrstRng As Range, Lrw As Long
Dim UnionRng As Range
Dim c As Range
Lrw = Cells(Rows.Count, "A").End(xlUp).Row
Set FrstRng = Range("A2:A" & Lrw)
For Each c In FrstRng.Cells
If Int(c / 50) / (c / 50) <> 1 Then
If Not UnionRng Is Nothing Then
Set UnionRng = Union(UnionRng, c) 'adds to the range
Else
Set UnionRng = c
End If
End If
Next c
UnionRng.EntireRow.Delete
End Sub
I would recommend a helper column that flags your data appropriately. Either through formula or VB.
Then use an Autofilter to select the the flags and then delete.
try here for sample code that will delete filtered data.
http://www.mrexcel.com/forum/excel-questions/460513-visual-basic-applications-code-delete-only-rows-filtered.html
It's been a while since I have used VBA on Excel.
I want to alphabetize the contents of each column on the sheet.
This is what I have:
Range("A1").Select
Range("A1:A19").Select
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet2").Sort
.SetRange Range("A1:A19")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("B1").Select
End Sub
How can I make this into a for loop that keeps going as long as the range is active?
Like this?
Option Explicit
Sub sample()
Dim i As Long
With Sheets("Sheet1")
For i = 1 To .UsedRange.Columns.Count
.Columns(i).Sort Key1:=.Cells(1, i), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Next i
End With
End Sub
Here you go. This code assumes your data is laid out in some type of table format. Also, it assumes you want the entire column sorted (including blanks and such). If you want to make the range more specific or just set it with a hard reference adjust the code where I commented.
Sub sortRange()
Dim wks As Worksheet
Dim loopRange As Range, sortRange As Range
Set wks = Worksheets("Sheet1")
With wks
'can change the range to be looped, but if you do, only include 1 row of the range
Set loopRange = Intersect(.UsedRange, .UsedRange.Rows(1))
For Each cel In loopRange
Set sortRange = Intersect(cel.EntireColumn, .UsedRange)
With .Sort
.SortFields.Clear
.SortFields.Add Key:=sortRange
.SetRange sortRange
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Next
End With
End Sub