Это было довольно странно, но я понял. Вставьте код в модуль. Убедитесь, что вы находитесь на главном листе, чтобы выполнить оценку и запустить transformTable().
Вот более / менее, как это работает:
- Просмотреть список
- Игнорировать любую строку с N в столбце Значение
- Создать коллекцию заказов
- Если заказ уже существует (на основе OrderNo, Product и Count), добавьте в него информацию (например, информацию о клиенте или варианте)
- Затем переберите коллекцию заказов и распечатайте ее на новом листе.
Надеюсь, вам понравится.
Option Explicit
Public Type OrderInfo
orderNo As Long
product As String
customer As String
productVariant As String
producctVariantName As String
productCount As Long
End Type
Public Sub transformTable()
Dim sh As Excel.Worksheet
Dim orders() As OrderInfo
Set sh = ActiveSheet
orders = buildOrders(sh)
Call createNewTable(orders)
End Sub
Private Sub createNewTable(ByRef orders() As OrderInfo)
Application.ScreenUpdating = False
Dim wb As Excel.Workbook
Dim newSh As Excel.Worksheet
Dim i As Long
Dim curRow As Long
curRow = 2
Set wb = ThisWorkbook
Set newSh = wb.Worksheets.Add
newSh.Range("A1:F1").Value = Array("OrderNo", "Product", "Cust", "Count", "Variant", "Variant Name")
For i = LBound(orders) To UBound(orders)
newSh.Cells(curRow, "A").Value = orders(i).orderNo
newSh.Cells(curRow, "B").Value = orders(i).product
newSh.Cells(curRow, "C").Value = orders(i).customer
newSh.Cells(curRow, "D").Value = orders(i).productCount
newSh.Cells(curRow, "E").Value = orders(i).productVariant
newSh.Cells(curRow, "F").Value = orders(i).producctVariantName
curRow = curRow + 1
Next i
Application.ScreenUpdating = True
End Sub
Private Function buildOrders(ByRef sh As Excel.Worksheet) As OrderInfo()
Dim lastRow As Long
Dim i As Long
Dim index As Long
Dim indexFound As Long
Dim orders() As OrderInfo
lastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
ReDim orders(0)
If (lastRow <= 1) Then
buildOrders = orders
Exit Function
End If
For i = 2 To lastRow
If (sh.Cells(i, "D").Value <> "N") Then
indexFound = findIndex(orders, sh.Cells(i, "A").Value, sh.Cells(i, "B").Value, sh.Cells(i, "E").Value)
If (indexFound = -1) Then
' add new orderInfo
ReDim Preserve orders(index)
If (sh.Cells(i, "C").Value = "Cust") Then
orders(index) = createOrderInfo(sh.Cells(i, "A").Value _
, sh.Cells(i, "B").Value _
, sh.Cells(i, "E").Value _
, sh.Cells(i, "D").Value)
ElseIf (InStr(1, sh.Cells(i, "C").Value, "Variant", vbTextCompare) > 0) Then
orders(index) = createOrderInfo(sh.Cells(i, "A").Value _
, sh.Cells(i, "B").Value _
, sh.Cells(i, "E").Value _
, productVariant:=Right(sh.Cells(i, "C").Value, 1) _
, productVariantName:=sh.Cells(i, "D").Value)
End If
index = index + 1
Else
' add customer or variant
If (sh.Cells(i, "C").Value = "Cust") Then
orders(indexFound).customer = sh.Cells(i, "D").Value
ElseIf (InStr(1, sh.Cells(i, "C").Value, "Variant", vbTextCompare) > 0) Then
orders(indexFound).productVariant = Right(sh.Cells(i, "C").Value, 1)
orders(indexFound).producctVariantName = sh.Cells(i, "D").Value
End If
End If
End If
Next i
buildOrders = orders
End Function
Private Function createOrderInfo(ByVal orderNo As Long _
, ByRef product As String _
, ByVal productCount As Long _
, Optional ByRef customer As String = "" _
, Optional ByRef productVariant As String = "" _
, Optional ByRef productVariantName As String = "") As OrderInfo
Dim oi As OrderInfo
oi.orderNo = orderNo
oi.product = product
oi.productCount = productCount
oi.customer = customer
oi.productVariant = productVariant
oi.producctVariantName = productVariantName
createOrderInfo = oi
End Function
Private Function findIndex(ByRef orders() As OrderInfo _
, ByVal orderNo As Long _
, ByRef product As String _
, ByVal productCount As Long) As Long
Dim i As Long
For i = LBound(orders) To UBound(orders)
If (orders(i).orderNo = orderNo And orders(i).product = product And orders(i).productCount = productCount) Then
findIndex = i
Exit Function
End If
Next i
findIndex = -1
End Function
