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.
Related
Here I tried to random the colons, however, it tell me cannot autofill, and same thing works for my randomRow()
Sub randomCol()
Dim Line As Integer
Line = LastRow + 1
Range("N154").Select
ActiveCell.FormulaR1C1 = "=RAND()"
Dim randomRange As String
randomRange = "N" & Line & ":BF" & Line
MsgBox randomRange
Selection.AutoFill Destination:=Range(randomRange), Type:=xlFillDefault
Range("N2:BF" & Line).Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add key:=Range("N" & LastRow + 1), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("N1:BF" & Line)
.Header = xlGuess
.MatchCase = False
.Orientation = xlLeftToRight
.Apply
End With
End Sub
AutoFill method requires that the destination must include the source range. Proper Syntax for autofill as follows for example only.
Set sourceRange = Worksheets("Sheet1").Range("A1:A2")
Set fillRange = Worksheets("Sheet1").Range("A1:A20")
sourceRange.AutoFill Destination:=fillRange
Accordingly I have modified your program and hope it should work fine.
Sub randomCol()
Dim Line As Integer
Line = LastRow + 1
Range("N154").Select
ActiveCell.FormulaR1C1 = "=RAND()"
Set SourceRange = Worksheets("Sheet1").Range("N154") 'Changed you can set the range required by you.
Dim randomRange As String
randomRange = "N" & Line & ":BF" & Line
Set fillRange = Worksheets("Sheet1").Range("n1:BF154") 'Set fill range appropriately but should include source range
MsgBox randomRange
'changed
'Selection.AutoFill Destination:=Range(randomRange), Type:=xlFillDefault
SourceRange.AutoFill Destination:=fillRange
Range("N2:BF" & Line).Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("N" & LastRow + 1), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("N1:BF" & Line)
.Header = xlGuess
.MatchCase = False
.Orientation = xlLeftToRight
.Apply
End With
End Sub
edit after OP's specification that LastRow is a function returning ActiveSheet.Cells(Rows.Count, "L").End(xlUp).Row
the destination must include the source range, while the latter is "N154" and the former are cells in row Line between columns "N" and "BF", so it'd work only if Line is 154.
moreover it's best to define both Line and LastRow() as of Long type instead of Integer
so that your code could change like follows:
Sub randomCol()
Dim Line As Long
Line = Lastrow + 1
Range("N" & Line).Select
ActiveCell.FormulaR1C1 = "=RAND()"
Dim randomRange As String
randomRange = "N" & Line & ":BF" & Line
MsgBox randomRange
Selection.AutoFill Destination:=Range(randomRange), Type:=xlFillDefault
Range("N2:BF" & Line).Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("N" & Line), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("N1:BF" & Line)
.Header = xlGuess
.MatchCase = False
.Orientation = xlLeftToRight
.Apply
End With
End Sub
Function LastRow() As Long
LastRow = ActiveSheet.Cells(Rows.count, "L").End(xlUp).Row
End Function
but you may also consider:
to avoid selections and activation
there's no need for Autofill actually, since you're simply pasting a formula
so your code can become:
Sub randomCol2()
Dim Line As Long
With ActiveWorkbook.Worksheets("Sheet1")
Line = .Cells(.Rows.count, "L").End(xlUp).Row + 1
.Columns("N:BF").Rows(Line).FormulaR1C1 = "=RAND()"
With .Sort
.SortFields.Clear
.SortFields.Add Key:=Range("N" & Line), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("N1:BF" & Line)
.Header = xlGuess
.MatchCase = False
.Orientation = xlLeftToRight
.Apply
End With
End With
End Sub
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.
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 am using the code below to sort a spreadsheet with various subtotals. On 5 out of 6 spreadsheets it works as expected. On the 6th spreadsheet I have encountered a problem with Excel ungrouping one row from a sub group. In the example below row 435 is removed from the rest of the group and row 436 has its height reduced to 0. I have looked at every cell in rows 435 and 436 and each matches the other rows in the group. After speaking with the users who would manually record a sorting macro they told me it sometimes happens to their spreadsheets as well. this macro works for the first 27 groups it has to sort. The subgroup I am having a problem with has 95 rows, other groups that have more rows do not have a problem.
Has anyone encountered this problem before and has anyone figured out how to deal with it?
The code I am using is below.
Sub mcrFindSortGroup()
Dim strFirstRow As String
Dim strLastRow As String
Dim LastCol As Integer
Dim c As Range
Dim strColumn As String
Application.DisplayAlerts = False
Application.EnableCancelKey = xlDisabled
Sheets("DCL Descriptions").Select
Range("H2:H2").Select
strColumn = ActiveCell
strColumn = strColumn - 1
Sheets("Sku Selling").Select
Columns("C:C").Select
For Each c In Range("DCL")
If c = "" Then GoTo DoneMsg
Cells(ActiveCell.Row, 1).Select
Range("C1:C15000").Activate
Selection.Find(What:=c, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
strFirstRow = ActiveCell.Row
Cells(ActiveCell.Row, 2).Select
If Cells(ActiveCell.Row + 1, 2) <> Cells(ActiveCell.Row, 2) Then
strLastRow = ActiveCell.Row
GoTo SkipSort
End If
Range(Selection, Selection.End(xlDown)).Select
strLastRow = ActiveCell.End(xlDown).Select
strLastRow = ActiveCell.Row
RowCount = (strLastRow - strFirstRow) + 1
Rows(strFirstRow & ":" & strLastRow).Select
ActiveWorkbook.Worksheets("Sku Selling").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sku Selling").Sort.SortFields.Add Key:=ActiveCell _
.Offset(0, strColumn).Range("A" & 1 & ":A" & RowCount) _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sku Selling").Sort
.SetRange ActiveCell.Range("A" & 1 & ":ZZ" & RowCount)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
SkipSort: ' the group has only 1 sku and does not need to be sorted
Next
DoneMsg:
MsgBox "Sorting Completed!", vbInformation, "Done"
Application.DisplayAlerts = True
Application.EnableCancelKey = xlErrorHandler
End Sub
These are before and after screen shots
Before:
After:
So the purpose of my macro is to add a version number to a part number. First a user will input all the data then my macro will create a new entry with that information at the bottom of the table. Then it will filter the table based on part number. Still within the filter I need it to look at the previous entry and add 1 for my current entry. For example if the previous was 01 the next would need to be 02 and so on. I am running into trouble getting my macro to run the add 1 part below is my code. I am thinking that it may not be possible within a filter or I have to write my code differently. Any insight would be awesome thanks!
'Update version number
Sheets("New Version ").Select
part = Range("B4").Value
Sheets("PN_List").Select
ActiveSheet.Range("$A$1:$K$3000").AutoFilter Field:=1, Criteria1:=part
ActiveWorkbook.Worksheets("PN_List").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("PN_List").AutoFilter.Sort.SortFields.Add Key:= _
Range("B1:B3000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets("PN_List").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Worksheets("PN_List").Activate
With Range("B" & Rows.Count).End(xlUp).Offset(1)
.Value = "0" & .Offset(-1).Value + 1
End With
Let's re-write your code a bit.
Dim wsNewVersion = Thiwworkbook.Sheets("New Version")
Dim wsPNList = Thiwworkbook.Sheets("PN_List")
part = wsNewVersion.Range("B4").Value
wsPNList.Range("A1:K3000").AutoFilter Field:= 1, Criteria1:=part
wsPNList.AutoFilter.Sort.SortFields.Clear
wsPNList.AutoFilter.Sort.SortFields.Add Key:= _
wsPNList.Range("B1:B3000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With wsPNList.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'~~> Below code is what you need i guess
Dim myrng As Range, lrow As Long
Dim myadd
'~~> Get the Range Address of the visible cells only
lrow = wsPNList.Range("A" & Rows.Count).End(xlUp).Row
Set myrng = wsPNList.Range("B1", Range("B" & lrow)).Offset(1, 0).Resize(lrow - 1).SpecialCells(xlCellTypeVisible)
'~~> pass addresses in array
myadd = Split(myrng.Address, ",")
'~~> Now you know the address, you can assign the value
With wsPNList
.Range(myadd(UBound(myadd))).Value = Range(myadd(UBound(myadd) - 1)).Value + 1
End With
Hope this is what you need.
I believe it is :) but who knows.
My guess is your cell is formatted as "General"
Right-click the cell, go to Format Cells. Change the Category to "text"
or, if you want it done within VBA, add this:
.Value = "0" & .Offset(-1).Value + 1
.Style = "Text"
Per request:
'Update version number
Sheets("New Version ").Select
part = Range("B4").Value
Sheets("PN_List").Select
ActiveSheet.Range("$A$1:$K$3000").AutoFilter Field:=1, Criteria1:=part
ActiveWorkbook.Worksheets("PN_List").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("PN_List").AutoFilter.Sort.SortFields.Add Key:= _
Range("B1:B3000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets("PN_List").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Worksheets("PN_List").Activate
With Range("B" & Rows.Count).End(xlUp).Offset(1)
' following line was added to set text format in the target cell
.NumberFormat = "#"
.Value = "0" & .Offset(-1).Value + 1
End With