Developing.ru

Код: Выделить всё

Sub m_1()
Dim vИмяФайла As String
Dim oWordDocument As Word.Document
Dim i As Byte
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = False
    .Show
    vИмяФайла = .SelectedItems(1)
End With
Set oWordDocument = GetObject(vИмяФайла)
For i = 1 To 10
    With oWordDocument.Words(i)
        Cells(i, 1).Value = .Text
        Cells(i, 2).Value = .Font.Size
        If .Font.Bold = True Then
            Cells(i, 3).Value = "Жирный"
        Else
            Cells(i, 3).Value = "Обычный"
        End If
    End With
Next i
oWordDocument.Close SaveChanges:=False
Set oWordDocument = Nothing
End Sub

Код: Выделить всё

Sub m_1()
Dim oWord As Word.Application
Dim oDocumentWord As Word.Document
Dim i As Long
Dim vНомерПоследнейСтроки As Long
Set oWord = CreateObject("Word.Application")
oWord.Visible = True
Set oDocumentWord = oWord.Documents.Add
vНомерПоследнейСтроки = Worksheets(1).Range("A1").SpecialCells(xlCellTypeLastCell).Row
For i = 1 To vНомерПоследнейСтроки
    If CDate(Cells(i, 2).Value) > Date And CDate(Cells(i, 2).Value) < DateAdd("d", 4, Date) Then
        oDocumentWord.Content.InsertAfter Chr(13) & Chr(13) & Cells(i, 2).Previous.Value & Chr(13) & Chr(13) & _
            "поздравлю тебя с днём рождения!"
    End If
Next i
Set oDocumentWord = Nothing
Set oWord = Nothing
End Sub

Код: Выделить всё

Sub m_1()
'Фамилии находятся в первом столбце книги Excel
    Dim vФИО As String
    Dim oWord As Word.Application
    Dim oWordDocument As Word.Document
    Dim oКнига As Excel.Workbook
    Dim vИмяКнига As String
    Dim vResponse As String
    Dim vРезультатПоиска As Range
    Dim vПоследнийСтолбец As Long
    Dim vПервыйАдрес As String
    Dim oFind As Range
    Dim i As Byte
    Set oWord = CreateObject("Word.Application")
    Set oWordDocument = oWord.Documents.Add
    oWord.Visible = True
    With oWordDocument
        With .PageSetup
            .Orientation = wdOrientLandscape
            .TopMargin = CentimetersToPoints(1)
            .BottomMargin = CentimetersToPoints(1)
            .LeftMargin = CentimetersToPoints(1)
            .RightMargin = CentimetersToPoints(1)
        End With
    End With
metka1:
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Show
        vИмяКнига = .SelectedItems(1)
    End With
    Set oКнига = Workbooks.Open(vИмяКнига)
    vФИО = InputBox("Введите ФИО по образцу: Фамилия И.О.")
    For i = 1 To 2
        oКнига.Worksheets(i & " семестр").Activate
        vПоследнийСтолбец = oКнига.Worksheets(i & " семестр").Range("A1").SpecialCells(xlCellTypeLastCell).Column
        With oКнига.Worksheets(i & " семестр").Range("A:A")
            Set oFind = .Find(What:=vФИО, LookIn:=xlValues, LookAt:=xlPart, _
                    SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False)
            If oFind Is Nothing Then
                oWordDocument.Content.InsertAfter String(2, Chr(13)) & _
                    oКнига.Name & vbCr & oКнига.Worksheets(i & " семестр").Name & vbCr & _
                    "Такого студента нет"
            Else
                vПервыйАдрес = oFind.Address
                Do
                    oКнига.Worksheets(i & " семестр").Range(Cells(oFind.Row, 1), Cells(oFind.Row, vПоследнийСтолбец)).Copy
                    oWordDocument.Content.InsertAfter String(2, Chr(13)) & _
                        oКнига.Name & vbCr & oКнига.Worksheets(i & " семестр").Name & vbCr
                        oWordDocument.Range(Start:=oWordDocument.Range.End - 1, End:=oWordDocument.Range.End).Paste
                Set oFind = .FindNext(oFind)
                Loop While Not oFind Is Nothing And vПервыйАдрес <> oFind.Address
            End If
        End With
    Next i
    vResponse = MsgBox("Взять оценки ещё по одному предмету?", vbYesNo)
    If vResponse = vbYes Then
        GoTo metka1
    End If
    Application.CutCopyMode = False
    Set oКнига = Nothing
    Set oWord = Nothing
    Set oWordDocument = Nothing
End Sub