Я начал делать код для своего второго варианта. Строки под таблицей добавляются. Пока не получается написать новый диапазон для таблицы
| Код |
|---|
Private Sub CommandButton1_Click()
Dim vRetVal
Dim fcell3 As Variant
Dim b As Variant
Dim LastRow3 As Integer
Dim vrowCol
Dim a As String
Dim c As String
Dim d As Variant
'Поиск заголовка над таблицей
Set fcell3 = Columns("A:A").Find(БазаФурнитуры.ИмяПодраздела.Text)
If Not fcell3 Is Nothing Then
'активная ячейка для определения имени таблицы
Worksheets(БазаФурнитуры.ИмяРаздела.Text).Range("A" & fcell3.Row + 2).Activate
End If
'Определение имени таблицы
Dim Obj As ListObject
If ActiveSheet.ListObjects.Count = 0 Then Exit Sub
For Each Obj In ActiveSheet.ListObjects
If Not Intersect(ActiveCell, Obj.Range) Is Nothing Then
'MsgBox Obj.Name 'ИМЯ ТАБЛИЦЫ
d = Obj.Name
Debug.Print ActiveSheet.ListObjects(Obj.Name).Range.Address
a = Range(ActiveSheet.ListObjects(Obj.Name).Range.Address(0, 0)).Row 'Первая строка в таблице
'MsgBox a
'Определение количества строк в таблице
LastRow3 = Range(Obj.Name).rows.Count
MsgBox LastRow3
b = a + LastRow3 + 1 'первая строка под таблицей для определения вставки строк
'MsgBox b
Sheets(ИмяРаздела.Text).Range("A" & b).Activate
End If
Next
'Определение количества строк для вставки и их вставка
vrowCol = InputBox("Сколько строк добавить?", "Ввод значений")
vrowCol = Val(vrowCol): If vrowCol = 0 Then Exit Sub
With ActiveCell
Application.ScreenUpdating = False
c = CStr(.Row) & ":" & CStr(.Row + vrowCol - 1)
'Range(CStr(.Row) & ":" & CStr(.Row + vrowCol - 1)).HorizontalAlignment = xlCenter 'выравнивание текста по центру ячейки в таблице, кроме наименования
'Range(CStr(.Row) & ":" & CStr(.Row + vrowCol - 1)).EntireColumn.AutoFit 'автоширина ячейки
rows(c).Insert Shift:=xlDown
Application.ScreenUpdating = True
End With
'Увеличение диапазона таблицы на количество вставленных строк
With ActiveSheet.ListObjects(d)
.Resize .Range.Resize(a + vrowCol)
End With
End Sub
|
