исправление ошибок

[toldo]

Задача

Условие. Написать макрос, который бы
1) создал новый документ
2) вставил в него таблицу из 10 строк и 3 столбцов
3) для каждого из установленных в системе шрифтов выводил :
в 1-м столбце - Порядковый номер шрифта,
во 2-м столбце - Название шрифта,
в 3-м столбце фразу "Computer IBM" данным шрифтом 12 пт
в 4-м столбце - фразу "Кафедра САиОИ" данным шрифтом 12 пт.

Sub lab31()
Application.Documents.Add.Activate
ActiveDocument.Tables.Add Range:=Selection.Range, numrows:=10,
numcolumns:=3, DefaultTableBehavior:=wdWord9TableB ehavior,
AutoFitBehavior:=wdAutoFitFixed

ActiveDocument.Tables.Item(1).Delet e
Dim kol As Integer
kol = Application.FontNames.Count
ActiveDocument.Tables.Add Range:=Selection.Range, numrows:=kol,
numcolumns:=4, DefaultTableBehavior:=wdWord9TableB ehavior,
AutoFitBehavior:=wdAutoFitFixe

For i = 1 To kol
Selection.SelectRow
Selection.Font.Name = Application.FontNames(i)
Selection.SelectCell
Selection.TypeText Text:=i
Selection.MoveRight unit:=wdCell, Count:=1
Selection.TypeText Text:=Selection.Font.Name
Selection.MoveRight unit:=wdCell, Count:=1
Selection.TypeText Text:="computer ibm"
Selection.MoveRight unit:=wdCell, Count:=1
Selection.TypeText Text:="Кафедра САиОИ"
Selection.MoveDown unit:=wdLine, Count:=1
Selection.MoveLeft unit:=wdCharacter, Count:=3
Next i





Задача

Условие. Написать макрос, который бы сжимал таблицы, удаляя в них пустые строки.
Sub DeleteEmptyRows()
LastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = LastRow To 1 Step -1
If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete
Next r
End Sub



буду очень признателен за помощь)

[shanemac51]

Sub lab31()
Application.Documents.Add.Activate


'ActiveDocument.Tables.Item(1).Delete
Dim kol As Integer
kol = Application.FontNames.Count
ActiveDocument.Tables.Add Range:=Selection.Range, numrows:=kol, _
numcolumns:=4, DefaultTableBehavior:=wdWord9TableBehavior, _
AutoFitBehavior:=wdAutoFitFixed

For i = 1 To kol
Debug.Print i;
Selection.SelectRow
Selection.Font.Name = Application.FontNames(i)
Selection.SelectCell
Selection.TypeText Text:=i
Selection.MoveRight unit:=wdCell, Count:=1
Selection.TypeText Text:=Selection.Font.Name
Selection.MoveRight unit:=wdCell, Count:=1
Selection.TypeText Text:="computer ibm"
Selection.MoveRight unit:=wdCell, Count:=1
Selection.TypeText Text:="Кафедра САиОИ"
Selection.MoveDown unit:=wdLine, Count:=1
Selection.MoveLeft unit:=wdCharacter, Count:=1
Next i

End Sub

[toldo]

Сообщение от shanemac51

Sub lab31()
Application.Documents.Add.Activate


'ActiveDocument.Tables.Item(1).Delete
Dim kol As Integer
kol = Application.FontNames.Count
ActiveDocument.Tables.Add Range:=Selection.Range, numrows:=kol, _
numcolumns:=4, DefaultTableBehavior:=wdWord9TableBehavior, _
AutoFitBehavior:=wdAutoFitFixed

For i = 1 To kol
Debug.Print i;
Selection.SelectRow
Selection.Font.Name = Application.FontNames(i)
Selection.SelectCell
Selection.TypeText Text:=i
Selection.MoveRight unit:=wdCell, Count:=1
Selection.TypeText Text:=Selection.Font.Name
Selection.MoveRight unit:=wdCell, Count:=1
Selection.TypeText Text:="computer ibm"
Selection.MoveRight unit:=wdCell, Count:=1
Selection.TypeText Text:="Кафедра САиОИ"
Selection.MoveDown unit:=wdLine, Count:=1
Selection.MoveLeft unit:=wdCharacter, Count:=1
Next i

End Sub

спасибо)))