Const WB_NAME = "Данные.xlsx"
'
Sub Тренажёрка()
Dim wb As Workbook
Dim sh As Worksheet
On Error Resume Next
Set wb = Workbooks(WB_NAME)
If Err <> 0 Then
MsgBox "Не найдена книга " & WB_NAME, vbInformation
Exit Sub
End If
Set sh = wb.Sheets(ActiveSheet.Name)
If Err <> 0 Then
MsgBox "Не найден лист " & ActiveSheet.Name, vbInformation
Exit Sub
End If
On Error GoTo 0
Dim a As Variant
Dim y As Long
With sh
y = .Cells(.Rows.Count, 1).End(xlUp).Row
a = .Range(.Cells(2, 1), .Cells(y, 7))
End With
Dim x As Integer
Dim b As Variant
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2) - 1)
For y = 1 To UBound(a, 1)
For x = 1 To 2
b(y, x) = a(y, x)
Next
For x = 4 To UBound(a, 2)
b(y, x - 1) = a(y, x)
Next
Next
With ActiveSheet
.Range(.Cells(3, 1), .Cells(.Rows.Count, .Columns.Count)).ClearContents
.Cells(3, 1).Resize(UBound(b, 1), UBound(b, 2)) = b
.Rows(2).Copy
.Rows(3).Resize(UBound(b, 1)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With
End Sub
|