Невозможно проверить это, но я думаю, что это должно работать, по крайней мере, до разделительной части (если что-то пойдет не так, вы можете найти другой путь или просто использовать опцию интерфейса для текстовых сообщений в столбцы):
Option Explicit
Sub Test()
Dim wsData As Worksheet, wsOutput As Worksheet, arrData As Variant, SplitRange As Range, i As Long
'You will need to check Microsoft Scripting Dictionary from your references for this to work:
Dim DictColD As New Scripting.Dictionary, DictColE As New Scripting.Dictionary
'Set the worksheets where we will work
With ThisWorkbook
Set wsData = .Sheets("InformatieData")
Set wsOutput = .Sheets("InformatieMMFilterResultaat")
End With
'Fill an array with the source data
arrData = wsData.UsedRange.Value 'this will get everything on the worksheet till the last used cell
'Lets assume, as you said that the order and position of the columns is A to E
For i = 2 To UBound(arrData) '2 because 1 is headers
'if the material with the thickness doesn't exist yet, add it along with its time on column D
If Not DictColD.Exists(arrData(i, 1) & "-" & arrData(i, 2)) Then
DictColD.Add arrData(i, 1) & "-" & arrData(i, 2), arrData(i, 4) 'Column D value
Else
'If the material with the thickness already exists, then sum its time on column D
DictColD(arrData(i, 1) & "-" & arrData(i, 2)) = DictColD(arrData(i, 1) & "-" & arrData(i, 2)) + arrData(i, 4)
End If
'Now the same for column E
'if the material with the thickness doesn't exist yet, add it along with its time on column E
If Not DictColE.Exists(arrData(i, 1) & "-" & arrData(i, 2)) Then
DictColE.Add arrData(i, 1) & "-" & arrData(i, 2), arrData(i, 5) 'Column E value
Else
'If the material with the thickness already exists, then sum its time on column E
DictColE(arrData(i, 1) & "-" & arrData(i, 2)) = DictColE(arrData(i, 1) & "-" & arrData(i, 2)) + arrData(i, 5)
End If
Next i
Erase arrData
'Now you've got 2 dictionaries along with all the data you need, you only need to throw it back to your sheet
With wsOutput 'I'm going to assume you already have the headers there so only the data will be pasted
.Cells(2, 1).Resize(DictColD.Count) = Application.Transpose(DictColD.Keys) 'Material & Thickness
.Cells(2, 4).Resize(DictColD.Count) = Application.Transpose(DictColD.Items) 'Col D Times
.Cells(2, 5).Resize(DictColE.Count) = Application.Transpose(DictColE.Items) 'Col E Times
'Now we need to separate material & thickness into 2 columns
Set SplitRange = .Range("A2", .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
SplitRange.TextToColumns Destination:=SplitRange, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="-", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
End With
End Sub
Это должно быть намного быстрее, чем ваш реальный код, так как он все работает в памяти.