admin管理员组文章数量:1278974
| Part Name | Issue Number | Sequence Number
A1 1 1
A1 1 2
**A1 2 1**
**A2 1 1**
A3 1 1
A3 1 2
A3 1 3
A3 2 1
A3 3 1
A3 4 1
A3 4 2
**A3 4 3**
A4 1 1
A4 1 2
**A4 1 3**
B1 1 1
B1 2 1
B1 2 2
B1 3 1
B1 3 2
B1 3 3
B1 3 4
B1 3 5
B1 3 6
B1 4 1
**B1 5 1**
So I have three columns , the first one is Part Number , Second is Issue Number and the third is Sequence number. I want to select the highest issue number for every part name and then the highest sequence number for that issue number and get all of them in a sperate excel sheet.
I used chatgpt and got this code. It doesn't work. If you know the solution please help.
Sub AlignDataAndCreateTabs()
Dim ws As Worksheet, newWs As Worksheet
Dim lastRow As Long, uniqueItem As Object
Dim rng As Range, cell As Range
Dim item As Variant, maxVal2 As Double, maxVal3 As Double
Dim dict As Object, sheetName As String
' Set reference to active sheet
Set ws = ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row ' Get last row in column A
Set uniqueItem = CreateObject("Scripting.Dictionary") ' Store unique items from Column A
Set dict = CreateObject("Scripting.Dictionary") ' Store max values for each unique item
' Loop through Column A to get unique items
For Each cell In ws.Range("A2:A" & lastRow)
item = cell.Value
If Not uniqueItem.Exists(item) Then
uniqueItem.Add item, Nothing
End If
Next cell
' Process each unique item
For Each item In uniqueItem.Keys
maxVal2 = -1: maxVal3 = -1 ' Initialize max values
' Loop through the sheet to find max in Column B for each unique Column A item
For Each cell In ws.Range("A2:A" & lastRow)
If cell.Value = item Then
If IsNumeric(cell.Offset(0, 1).Value) And cell.Offset(0, 1).Value > maxVal2 Then
maxVal2 = cell.Offset(0, 1).Value
End If
End If
Next cell
' Find max in Column C corresponding to maxVal2
For Each cell In ws.Range("A2:A" & lastRow)
If cell.Value = item And cell.Offset(0, 1).Value = maxVal2 Then
If IsNumeric(cell.Offset(0, 2).Value) And cell.Offset(0, 2).Value > maxVal3 Then
maxVal3 = cell.Offset(0, 2).Value
End If
End If
Next cell
' Store results
dict.Add item, Array(maxVal2, maxVal3)
Next item
' Create new sheets and add selected values
Application.ScreenUpdating = False
For Each item In dict.Keys
' Sanitize sheet name
sheetName = Left(WorksheetFunction.Clean(CStr(item)), 31)
sheetName = Replace(sheetName, "\", "_")
sheetName = Replace(sheetName, "/", "_")
sheetName = Replace(sheetName, "?", "_")
sheetName = Replace(sheetName, "*", "_")
sheetName = Replace(sheetName, "[", "_")
sheetName = Replace(sheetName, "]", "_")
On Error Resume Next
Set newWs = ThisWorkbook.Sheets(sheetName)
On Error GoTo 0
If newWs Is Nothing Then
Set newWs = ThisWorkbook.Sheets.Add
newWs.Name = sheetName
End If
' Write headers
newWs.Cells(1, 1).Value = "Item"
newWs.Cells(1, 2).Value = "Max Column B"
newWs.Cells(1, 3).Value = "Max Column C"
' Write values
Dim rowIndex As Integer
rowIndex = 2
For Each cell In ws.Range("A2:A" & lastRow)
If cell.Value = item Then
newWs.Cells(rowIndex, 1).Value = item
newWs.Cells(rowIndex, 2).Value = dict(item)(0)
newWs.Cells(rowIndex, 3).Value = dict(item)(1)
rowIndex = rowIndex + 1
End If
Next cell
Set newWs = Nothing
Next item
Application.ScreenUpdating = True
End Sub
| Part Name | Issue Number | Sequence Number
A1 1 1
A1 1 2
**A1 2 1**
**A2 1 1**
A3 1 1
A3 1 2
A3 1 3
A3 2 1
A3 3 1
A3 4 1
A3 4 2
**A3 4 3**
A4 1 1
A4 1 2
**A4 1 3**
B1 1 1
B1 2 1
B1 2 2
B1 3 1
B1 3 2
B1 3 3
B1 3 4
B1 3 5
B1 3 6
B1 4 1
**B1 5 1**
So I have three columns , the first one is Part Number , Second is Issue Number and the third is Sequence number. I want to select the highest issue number for every part name and then the highest sequence number for that issue number and get all of them in a sperate excel sheet.
I used chatgpt and got this code. It doesn't work. If you know the solution please help.
Sub AlignDataAndCreateTabs()
Dim ws As Worksheet, newWs As Worksheet
Dim lastRow As Long, uniqueItem As Object
Dim rng As Range, cell As Range
Dim item As Variant, maxVal2 As Double, maxVal3 As Double
Dim dict As Object, sheetName As String
' Set reference to active sheet
Set ws = ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row ' Get last row in column A
Set uniqueItem = CreateObject("Scripting.Dictionary") ' Store unique items from Column A
Set dict = CreateObject("Scripting.Dictionary") ' Store max values for each unique item
' Loop through Column A to get unique items
For Each cell In ws.Range("A2:A" & lastRow)
item = cell.Value
If Not uniqueItem.Exists(item) Then
uniqueItem.Add item, Nothing
End If
Next cell
' Process each unique item
For Each item In uniqueItem.Keys
maxVal2 = -1: maxVal3 = -1 ' Initialize max values
' Loop through the sheet to find max in Column B for each unique Column A item
For Each cell In ws.Range("A2:A" & lastRow)
If cell.Value = item Then
If IsNumeric(cell.Offset(0, 1).Value) And cell.Offset(0, 1).Value > maxVal2 Then
maxVal2 = cell.Offset(0, 1).Value
End If
End If
Next cell
' Find max in Column C corresponding to maxVal2
For Each cell In ws.Range("A2:A" & lastRow)
If cell.Value = item And cell.Offset(0, 1).Value = maxVal2 Then
If IsNumeric(cell.Offset(0, 2).Value) And cell.Offset(0, 2).Value > maxVal3 Then
maxVal3 = cell.Offset(0, 2).Value
End If
End If
Next cell
' Store results
dict.Add item, Array(maxVal2, maxVal3)
Next item
' Create new sheets and add selected values
Application.ScreenUpdating = False
For Each item In dict.Keys
' Sanitize sheet name
sheetName = Left(WorksheetFunction.Clean(CStr(item)), 31)
sheetName = Replace(sheetName, "\", "_")
sheetName = Replace(sheetName, "/", "_")
sheetName = Replace(sheetName, "?", "_")
sheetName = Replace(sheetName, "*", "_")
sheetName = Replace(sheetName, "[", "_")
sheetName = Replace(sheetName, "]", "_")
On Error Resume Next
Set newWs = ThisWorkbook.Sheets(sheetName)
On Error GoTo 0
If newWs Is Nothing Then
Set newWs = ThisWorkbook.Sheets.Add
newWs.Name = sheetName
End If
' Write headers
newWs.Cells(1, 1).Value = "Item"
newWs.Cells(1, 2).Value = "Max Column B"
newWs.Cells(1, 3).Value = "Max Column C"
' Write values
Dim rowIndex As Integer
rowIndex = 2
For Each cell In ws.Range("A2:A" & lastRow)
If cell.Value = item Then
newWs.Cells(rowIndex, 1).Value = item
newWs.Cells(rowIndex, 2).Value = dict(item)(0)
newWs.Cells(rowIndex, 3).Value = dict(item)(1)
rowIndex = rowIndex + 1
End If
Next cell
Set newWs = Nothing
Next item
Application.ScreenUpdating = True
End Sub
4 Answers
Reset to default 3As per comment, you can achieve this by the following formula-
=DROP(REDUCE("",UNIQUE(A1:A26),LAMBDA(acc,data,VSTACK(acc,TAKE(SORT(FILTER(A1:C26,A1:A26=data),{2,3},{-1,-1}),1)))),1)
If TRIMRANGE() is available then could refer full columns.
=DROP(REDUCE("",UNIQUE(A.:.A),LAMBDA(acc,data,VSTACK(acc,TAKE(SORT(FILTER(A.:.C,A.:.A=data),{2,3},{-1,-1}),1)))),1)
And with header-
=REDUCE({"Part No","Issue No","Sequence No"},UNIQUE(A1:A26),LAMBDA(a,x,VSTACK(a,TAKE(SORT(FILTER(A1:C26,A1:A26=x),{2,3},{-1,-1}),1))))
Input Data:
| A1 | 1 | 1 |
|---|---|---|
| A1 | 1 | 2 |
| A1 | 2 | 1 |
| A2 | 1 | 1 |
| A3 | 1 | 1 |
| A3 | 1 | 2 |
| A3 | 1 | 3 |
| A3 | 2 | 1 |
| A3 | 3 | 1 |
| A3 | 4 | 1 |
| A3 | 4 | 2 |
| A3 | 4 | 3 |
| A4 | 1 | 1 |
| A4 | 1 | 2 |
| A4 | 1 | 3 |
| B1 | 1 | 1 |
| B1 | 2 | 1 |
| B1 | 2 | 2 |
| B1 | 3 | 1 |
| B1 | 3 | 2 |
| B1 | 3 | 3 |
| B1 | 3 | 4 |
| B1 | 3 | 5 |
| B1 | 3 | 6 |
| B1 | 4 | 1 |
| B1 | 5 | 1 |
Output result:
| A1 | 2 | 1 |
|---|---|---|
| A2 | 1 | 1 |
| A3 | 4 | 3 |
| A4 | 1 | 3 |
| B1 | 5 | 1 |
Looks like ChatGPT just misunderstood the "..in a sperate excel sheet.". Replace the last part with this ;
' Create new sheets and add selected value
sheetName = "Results"
On Error Resume Next
Set newWs = ThisWorkbook.Sheets(sheetName)
On Error GoTo 0
If newWs Is Nothing Then
Set newWs = ThisWorkbook.Sheets.Add
newWs.Name = sheetName
End If
' Write headers
newWs.Cells(1, 1).Value = "Item"
newWs.Cells(1, 2).Value = "Max Column B"
newWs.Cells(1, 3).Value = "Max Column C"
Dim rowIndex As Long
rowIndex = 2
For Each item In dict.Keys
' Write values
newWs.Cells(rowIndex, 1).Value = item
newWs.Cells(rowIndex, 2).Value = dict(item)(0)
newWs.Cells(rowIndex, 3).Value = dict(item)(1)
rowIndex = rowIndex + 1
Next item
This is a VBA code for this task placed in a Module
Sub selectmaxvalue()
Dim coll As Collection
Dim oldsh As Worksheet
Dim newsh As Worksheet
Dim rng As Range
Set coll = New Collection
Set oldsh = ActiveSheet
Set newsh = Worksheets.Add
oldsh.Range("A1").CurrentRegion.Offset(1, 0).Resize(oldsh.Range("A1").CurrentRegion.Rows.count - 1).Copy Range("a1")
Set rng = Range("A1").CurrentRegion
rng.Sort Columns(1), xlAscending, Columns(2), , xlAscending, Columns(3), xlAscending
For i = 1 To rng.Rows.count
If Cells(i, 1) <> Cells(i + 1, 1) Then
coll.Add Rows(i)
End If
Next i
For i = 1 To coll.count
Rows(rng.Rows.count + i).Value = coll(i).Value
Next i
rng.Delete
Range("A1:C1").Insert xlShiftDown
Range("A1:C1") = Array("Part No", "Issue", "Sequence")
End Sub
- First sort the range for the three columns
- Create a new worksheet and copy the sorted range to it
- Add after the range the rows with the max values
- Remove the sorted range and create a header for the max values.
An alternative solution to extract the data without using a Dictionary object or Collection object.
Sub Demo()
Dim i As Long, j As Long
Dim arrData, rngData As Range
Dim arrRes, iR As Long
Dim srcSht As Worksheet: Set srcSht = Sheets("Sheet1")
Sheets.Add
srcSht.Range("A1").CurrentRegion.Copy Range("A1")
' sort the table
Set rngData = Range("A1").CurrentRegion
With rngData
.Sort key1:=.Cells(1, 1), order1:=xlAscending, _
key2:=.Cells(1, 2), order2:=xlAscending, _
key3:=.Cells(1, 3), order2:=xlAscending, _
Header:=xlYes
End With
Set rngData = rngData.Resize(rngData.Rows.Count + 1)
' load table into an array
arrData = rngData.Value
Dim RowCnt As Long: RowCnt = UBound(arrData)
Dim ColCnt As Long: ColCnt = UBound(arrData, 2)
ReDim arrRes(1 To RowCnt, 1 To ColCnt)
' loop through rows
For i = LBound(arrData) To UBound(arrData) - 1
If Not arrData(i, 1) = arrData(i + 1, 1) Then
iR = iR + 1
' extract row
For j = LBound(arrData, 2) To UBound(arrData, 2)
arrRes(iR, j) = arrData(i, j)
Next j
End If
Next i
' write output to new sheet
rngData.Clear
Range("A1").Resize(iR, ColCnt).Value = arrRes
End Sub
Microsoft documentation:
Range.Resize property (Excel)
本文标签：
版权声明：本文标题：excel - How to select the highest Number in a column in accordance to Highest number in another column - Stack Overflow 内容由网友自发贡献，该文观点仅代表作者本人， 转载请联系作者并注明出处：http://www.betaflare.com/web/1741288034a2370385.html， 本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌抄袭侵权/违法违规的内容，一经查实，本站将立刻删除。
FILTER(A2:F26...Try=DROP(REDUCE("",UNIQUE(A1:A26),LAMBDA(acc,data,VSTACK(acc,TAKE(SORT(FILTER(A1:F26,A1:A26=data),{2,3},{-1,-1}),1)))),1). – Harun24hr Commented Feb 24 at 9:16