Я предлагаю вам поместить свои результаты на отдельную страницу (или в другую область того же рабочего листа.
Вместо нескольких обращений к / с рабочего листа было бы намного быстрее
- прочитать данные в массив VBA
- обработать
- создать новый массив для результатов
- записать и отформатировать его обратно в какое-то место назначения
Я предлагаю создать определяемый пользователем объект (класс) для хранения данных для каждой итерации кода, чтобы упростить создание массива результатов.
Я думаю, что приведенный ниже код аннотирован достаточно хорошо, чтобы вы могли понять, что происходит, но не стесняйтесь задавать вопросы.
Обязательно установите ссылку (см. Инструменты / Ссылки) на Microsoft Scripting Runtime
Класс Модуль
Переименовать этот модуль cPower
Option Explicit
Private pPower As String
Private pCode As String
Private pposD As Long
Private pnegD As Long
Private pDMW As Long
Private pMW As Long
Private pDays As Collection
Private pNights As Collection
Public Property Get Power() As String
Power = pPower
End Property
Public Property Let Power(Value As String)
pPower = Value
End Property
Public Property Get Code() As String
Code = pCode
End Property
Public Property Let Code(Value As String)
pCode = Value
End Property
Public Property Get posD() As Long
posD = pposD
End Property
Public Property Let posD(Value As Long)
pposD = Value
End Property
Public Property Get negD() As Long
negD = pnegD
End Property
Public Property Let negD(Value As Long)
pnegD = Value
End Property
Public Property Get DMW() As Long
DMW = pDMW
End Property
Public Property Let DMW(Value As Long)
pDMW = Value
End Property
Public Property Get MW() As Long
MW = pMW
End Property
Public Property Let MW(Value As Long)
pMW = Value
End Property
Public Property Get Days() As Collection
Set Days = pDays
End Property
Public Function addDays(Values() As Long)
pDays.Add Values
End Function
Public Property Get Nights() As Collection
Set Nights = pNights
End Property
Public Function addNights(Values() As Long)
pNights.Add Values
End Function
Private Sub Class_Initialize()
Set pDays = New Collection
Set pNights = New Collection
End Sub
Обычный модуль
'Set Reference to Microsoft Scripting Runtime
Option Explicit
Sub Power()
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc, vRes, V, W
Dim cP As cPower, dP As Dictionary
Dim I As Long, J As Long, sKey As String, L(3) As Long
Dim R As Range
'Set source and results worksheets, ranges
Set wsSrc = ThisWorkbook.Worksheets("Sheet1")
On Error Resume Next
Set wsRes = ThisWorkbook.Worksheets("Results")
Select Case Err.Number
Case 9
ThisWorkbook.Worksheets.Add after:=wsSrc
ActiveSheet.Name = "Results"
Set wsRes = ThisWorkbook.Worksheets("Results")
Case Is <> 0
Debug.Print "Error: "; Err.Description, "Number: "; Err.Number
End Select
On Error GoTo 0
Set rRes = wsRes.Cells(1, 1)
'read source data into vba array
With wsSrc
'Find the start of the data = "Power"
Set R = .Cells.Find(what:="Power", after:=.Cells(.Rows.Count, .Columns.Count), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
If R Is Nothing Then
MsgBox "Table not on worksheet"
Exit Sub
End If
vSrc = .Range(.Cells(R.Row, R.Column), .Cells(.Rows.Count, R.Column).End(xlUp)).Resize(columnsize:=6)
End With
'collect the data
Set dP = New Dictionary
For I = 2 To UBound(vSrc, 1)
Set cP = New cPower
With cP
.Power = vSrc(I, 1)
.Code = Split(vSrc(I, 2), " ")(0)
sKey = .Code
.posD = vSrc(I, 3)
.negD = vSrc(I, 4)
.DMW = vSrc(I, 5)
.MW = vSrc(I, 6)
L(0) = .posD
L(1) = .negD
L(2) = .DMW
L(3) = .MW
If Not dP.Exists(sKey) Then
If Split(vSrc(I, 2), " ")(1) = "Day" Then
.addDays L
Else
.addNights L
End If
dP.Add Key:=sKey, Item:=cP
Else
If Split(vSrc(I, 2), " ")(1) = "Day" Then
dP(sKey).addDays L
Else
dP(sKey).addNights L
End If
End If
End With
Next I
'Create Results Array
'Rows = 2 header rows plus six data rows
'Columns = dictionary.count *4 + 2
ReDim vRes(0 To 7, 1 To dP.Count * 4 + 2)
'Headers
vRes(1, 1) = "Power"
vRes(1, 2) = "Day/Night"
J = 3
For Each W In dP.Keys
vRes(0, J) = W
J = J + 4
Next W
'Store the measurements into an array
'to be added to either the Days or Nights collection
For J = 3 To UBound(vRes, 2) Step 4
vRes(1, J) = "d"
vRes(1, J + 1) = "-d"
vRes(1, J + 2) = "dmw"
vRes(1, J + 3) = "mw"
Next J
'Day/Night Column
For I = 2 To 4
vRes(I, 2) = "Day"
Next I
For I = 5 To 7
vRes(I, 2) = "Night"
Next I
'populate
Dim lCol As Long, lRow As Long
For Each V In dP.Keys
I = 3
Do Until vRes(0, I) = V
I = I + 4
Loop
lCol = I
I = 2
For Each W In dP(V).Days
For J = 0 To 3
vRes(I, lCol + J) = W(J)
Next J
vRes(I, 1) = dP(V).Power
I = I + 1
Next W
I = 5
For Each W In dP(V).Nights
For J = 0 To 3
vRes(I, lCol + J) = W(J)
Next J
vRes(I, 1) = dP(V).Power
I = I + 1
Next W
Next V
'Write the results
'Format the output
Application.ScreenUpdating = False
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
With .Rows(2)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.Style = "Output" 'Note: This may not be internationally applicable
.EntireColumn.ColumnWidth = 255
.EntireColumn.AutoFit
With Range(.Columns(3), Columns(UBound(vRes, 2)))
.ColumnWidth = 5
.HorizontalAlignment = xlCenter
End With
For J = 3 To UBound(vRes, 2) Step 4
Set R = Range(.Columns(J), .Columns(J + 3))
With R
.BorderAround Weight:=xlThick
Range(.Cells(1, 1), .Cells(1, 4)).HorizontalAlignment = xlCenterAcrossSelection
End With
Next J
End With
End Sub
Исходные данные
Results
введите описание изображения здесь
Примечание: Это необходимо будет изменить, если в отличие от вашего примера, у вас есть несколько наборов с разными степенями, которые необходимо обработать иначе