Sub fltbl()
Application.DisplayAlerts = False
Dim mass()
lr = ActiveSheet.UsedRange.Rows.Count
lc = ActiveSheet.UsedRange.Columns.Count
ReDim mass(1 To (lr - 3) * (lc - 5), 1 To 7) ' lr-3 - минус 3 первые строки шапки, lc-5 - марки с 6-го столбца, поэтому -5
n = 3 'номер первой строки с названиями марок
For i = 4 To lr ' с четвертой строки начинаем сбор данных
If Cells(i, 3).Value = "" Then
n = i 'следующая строка с марками, когда в третьем столбце пусто
Else
For j = 6 To lc Step 2 ' марки с 6-го столбца
If Cells(n, j).Value <> "" Then
a = a + 1
mass(a, 1) = Cells(i, 1).Value: mass(a, 2) = Cells(i, 2).Value
mass(a, 3) = Cells(i, 3).Value: mass(a, 4) = Cells(i, 4).Value
mass(a, 5) = Cells(i, 5).FormulaLocal: mass(a, 6) = Cells(n, j).Value
mass(a, 7) = Cells(i, j).FormulaLocal
End If
Next
End If
Next
Worksheets.Add
Range("A2").Resize(a, 7).Value = mass()
Application.DisplayAlerts = True
End Sub
Sub fltbl()Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim mass()
lr = ActiveSheet.UsedRange.Rows.Count
lc = ActiveSheet.UsedRange.Columns.Count
ReDim mass(1 To (lr - 3) * (lc - 5), 1 To 7) ' lr-3 - минус 3 первые строки шапки, lc-5 - марки с 6-го столбца, поэтому -5
n = 3 'номер первой строки с названиями марок
For i = 4 To lr ' с четвертой строки начинаем сбор данных
If Cells(i, 3).Value = "" Then
n = i 'следующая строка с марками, когда в третьем столбце пусто
Else
For j = 6 To lc Step 2 ' марки с 6-го столбца
If Cells(n, j).Value <> "" Then
a = a + 1
mass(a, 1) = Cells(i, 1).Value: mass(a, 2) = Cells(i, 2).Value
mass(a, 3) = Cells(i, 3).Value: mass(a, 4) = Cells(i, 4).Value
mass(a, 5) = Cells(i, 5).FormulaLocal: mass(a, 6) = Cells(n, j).Value
mass(a, 7) = Cells(i, j).FormulaLocal
End If
Next
End If
Next
Worksheets.Add
For i = 2 To a + 1
For j = 1 To 7
If j = 5 Or j = 7 Then
Cells(i, j).FormulaLocal = mass(i - 1, j)
Else
Cells(i, j).Value = mass(i - 1, j)
End If
Next
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub