Нужна помощь с решением

[Fasmon]

Нужно решить написать 3 небольших програмки.
У самого с этим направлением что-то все не то идет...
Задачи:

1. Макрос эксель открывает документ ворд, просматривает первые 10 слов и параметры их форматирования заносит в строчки эксель, Например: слово, размер в пунктах, жирность

2. Из 2х книг эксель с успеваемостью по 2 предметам (на разных листах разные семестры) вывести успеваемость 1 студента по всем предметам и семестрам в документ ворд

3. В книге эксель помещен список ваших друзей и их дни рождения. Проанализировать, у кого дни рождения будут в ближ. три дня и написать в документ ворд поздравления

Зарание спасибо

[Busine2009]

По первому вопросу.
В VBE: Tools - References... - Microsoft Word 11.0 Object Library (если Office 2007, то Microsoft Word 12.0 Object Library) - Окей
Чтобы не было ошибки, в документе Word должно быть не менее 10 слов.
В Word специальные символы тоже является словами, поэтому в Excel могут появиться квадратики вместо слов (квадратик означает непечатаемый символ "Конец абзаца"). Чтобы увидеть символ "Конец абзаца", надо включить режим отображения непечатаемых символов.

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

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

По второму вопросу задание не понятно.

[Fasmon]

Можете этот код в эксель файле выложить ? )

По второму - есть 2 эксель книги. В них успеваемость студентов (1 лист - 1 семестр, 2 лист - второй). Нужно из этих книг в документ ворд вывести "статистику"(все предметы, оба семестра) по одному студенту (видимо с выбором его). Я вот так это понял

[Busine2009]

Можете этот код в эксель файле выложить ? )

1. Откройте пустую книгу Excel - Сервис - Макрос - Начать запись... - Сохранить в: "личная книга макросов" - Окей.
2. Введите букву "а" - Нажмите Enter.
3. Сервис - Макрос - Остановить запись.
4. Перейдите в VBE - там появился новый проект PERSONAL.XLS. Дважды щ. по PERSONAL.XLS - откройте любой модуль (если их там несколько) Module - поместите в него код из этого форума.
5. Нажмите Сохранить

Макрос не будет работать, если не сделаете вот это
В VBE: Tools - References... - Microsoft Word 11.0 Object Library (если Office 2007, то Microsoft Word 12.0 Object Library) - Окей

[Busine2009]

Fasmon
уточнение по второму вопросу.
Есть две книги Excel: в одной книге успеваемость по одному предмету, а во второй книге успеваемость по др. предмету. Нужно в Word указать успеваемость заданного студента по этим двум предметам. Я правильно понял?

По третьему вопросу:
В 1-ом столбце книги Excel находятся имена друзей, во 2-ом - даты рождения в таком формате: 1 января, 6 сентября

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

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

[Fasmon]

Во втором, я сам точно не знаю, что именно должно быть в разных книгах )
Ну наверно так пойдет, как сказали.

[Busine2009]

Вторая программка. Листы в книгах Excel должны иметь только такие имена "1 семестр" и "2 семестр". После того, как откроется пустой документ Word, нужно перейти в Excel и выбрать нужный файл Excel (успеваемость по определённому предмету). После того, как данные будут взяты из первой книги, будет предложено взять данные из др. книги.

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

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

[Fasmon]

во втором пишет ошибку Type mismatch на строчке:

If CDate(Cells(i, 2).Value) > Date And CDate(Cells(i, 2).Value) < DateAdd("d", 4, Date) Then

и в третьем - что-то видно не так делаю, т.к. при запуске открывается вордовский документ и вместе с экселем виснут )
Просьба третий кинуть в готовом эксель документе (с данными нужными в самих ячейках)

P.S. первая работает.

[Busine2009]

Во вложении файл по 3 вопросу.

и в третьем - что-то видно не так делаю, т.к. при запуске открывается вордовский документ и вместе с экселем виснут )

Перейдите в Excel и продолжите работу.

[Fasmon]

А со вторым что ?