Microsoft Excel:

  Таблицы и VBA. Справочник.
  Вопросы и Ответы. Советы. Примеры.
Меню FAQ | Макросы | Общие вопросы


Rambler's Top100


Counter CO.KZ


    [1] [2] [3]

  1. Как воспользоваться событиями приложения ? 06.09.2016
  2. Как при использовании событий приложения определить рабочую книгу - источник события ? 26.09.2016
  3. Как отловить двойной клик в любой из ячеек определённого рабочего листа ? 26.09.2016
  4. Как добавить свой текст в список стандартной Автозамены, а также, как определить наличие текста в этом списке и удалить уже ненужный ? 28.09.2016
  5. Как используя ячейки рабочего листа, вывести весь список стандартной Автозамены ? 28.09.2016
  6. Как программно об'единить все текстовые файлы в один ? 17.08.2011
  7. Как создать список всех непрочитанных писем из папки Входящие Microsoft Outlook (не Outlook Express) ? 17.10.2014
  8. Как с помощью DAO создать новую рабочую книгу .xls в указанной папке ? 25.09.2016
  9. Как с помощью DAO получить перечень всех видимых рабочих листов закрытой рабочей книги ? 13.11.2014
  10. Как сортировать по части значения в столбце с помощью MS Query ? 05.01.2016
    [1] [2] [3]


  • Ответ : Скачать пример

    Если Вы считаете, что событие листа/книги не может помочь в решении поставленной задачи и необходимо использовать событие приложения, то выберите необходимую книгу, например, "Personal.xls" (Excel97-2003) или "Personal.xlsb" (Excel2007) и скопируйте в модуль книги ThisWorkbook(ЭтаКнига) следующий код :
  • Private WithEvents xlApp As Excel.Application
    
    Private Sub Workbook_Open()
        Set xlApp = Excel.Application
    End Sub
    Теперь, выбрав в первом поле со списком xlApp, во втором, Вы получите полный список событий, которые можно использовать в текущей версии приложения
  • Ответ :

    Если Вы используете событие приложения, то возможно замечали, что у некоторых событий отсутствует параметр - книга, где было сгенерировано событие. Но иногда, возникает необходимость в том, чтобы определить, а в какой же, собственно, книге произошло это событие. В этом случае, можно использовать 100% надёжный вариант, а именно, свойство Parent об'екта Лист, т.е.
  • Private Sub xlApp_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
        MsgBox "Произошли изменения в книге " & Sh.Parent.Name
    End Sub
    Примечание : Если Вам кажется, что есть более простой вариант, а именно ActiveWorkbook, то это не так. Во-первых, если некий макрос изменит значения ячеек неактивной книги, а мы используем ActiveWorkbook, то получим ошибочные сведения о источнике возникновения события. А во-вторых, символов в тексте ActiveWorkbook всё-таки больше, чем в Sh.Parent
  • Ответ :

    Если Вам необходимо отловить двойной клик в любой из ячеек определённого рабочего листа, то :

    Вариант I. Скопируйте весь нижеопубликованный код в любой стандартный модуль необходимой книги и укажите имя или индекс рабочего листа, где необходимо следить за действиями пользователя.
  • Private Sub Auto_Open()
        Worksheets("Лист1").OnDoubleClick = "DoubleClick"
    End Sub
    
    Private Sub DoubleClick()
        MsgBox "Вы осуществили двойной клик по ячейке " & ActiveCell.Address
        SendKeys "{F2}" 'Если нужен переход в режим редактирования
    End Sub
    Вариант II. Скопируйте весь нижеопубликованный код именно в модуль листа, где планируется отлавливать двойной клик.
    Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
        MsgBox "Вы осуществили двойной клик по ячейке " & Target.Address
        Cancel = True 'Если нужно запретить переход в режим редактирования
    End Sub

  • Ответ :

    Если Вам необходимо программно добавить свой текст в список стандартной Автозамены, то осуществить это действие, можно так :
  • Application.AutoCorrect.AddReplacement "очепятка", "опечатка"
    В этом примере мы добавляем неправильный текст "очепятка", а меняться этот текст должен на "опечатка". Обратите внимание на то, что перед добавлением текста, проверять его наличие - не нужно, т.к. в случае его наличия, произойдёт просто замена старого текста на новый.

    Если же Вам понадобится программно удалить ненужный текст из списка Автозамены, то осуществить это можно так :
    Application.AutoCorrect.DeleteReplacement "очепятка"
    Обратите внимание на то, что перед удалением текста, необходимо проверять его наличие, т.к. в случае его отсутствия, возникнет ошибка 1004, которой можно избежать, если, используя нижеопубликованную функцию, просто проверить его наличие.
    Private Function IsExistText(Text$) As Boolean
        Dim iCount&, iArr
        iArr = Application.AutoCorrect.ReplacementList
        For iCount = 1 To UBound(iArr)
            If StrComp(iArr(iCount, 1), Text, vbTextCompare) = 0 Then
               IsExistText = True: Exit Function
            End If
        Next
    End Function
    Пример её вызова :
    Private Sub Test()
        If IsExistText("очепятка") = True Then
           Application.AutoCorrect.DeleteReplacement "очепятка"
        End If
    End Sub

  • Ответ :

    Если Вам необходимо получить весь список стандартной Автозамены, а затем вывести этот список в незащищённые ячейки активного рабочего листа, то :
  • Private Sub CreateAutoCorrectList()
        iArr = Application.AutoCorrect.ReplacementList
        
        Range("A2").Resize(UBound(iArr), 2) = iArr
        With Range("A1:B1")
             .Value = Array("Заменять:", "На:")
             .Font.Bold = True
             .EntireColumn.AutoFit
        End With
    End Sub

  • Ответ :

    Если Вам необходимо создать текстовый файл, содержащий данные всех текстовых файлов, находящихся в определённой папке, то используйте нижеопубликованный макрос, естественно, не забыв указать(выбрать) исходную папку, а также имя итогового(результирующего) файла.
  • Private Sub ConcatenateTextFiles()
        Dim iPath$, iFileName$, iText$
        
        iPath = "C:\Мониторинг\2005\04\"
        iFileName = Dir(iPath & "*.txt")
        
        If iFileName <> "" Then
           Do
                Open iPath & iFileName For Input As #1
                     iText = iText & vbNewLine & Input(LOF(1), #1)
                Close #1
                iFileName = Dir
           Loop Until iFileName = ""
           
           Open iPath & "Result.txt" For Output As #1
                Print #1, iText 'Write #1, iText
           Close #1
        End If    
    End Sub
    Комментарий : Если текстовый файл, содержащий об'единённые данные, будет находиться в той же папке, что и исходные файлы, то при повтором запуске макроса, его данные также будут участвовать в об'единении. Чтобы этого избежать, достаточно просто создавать итоговый файл в другой папке.


    Если же, при об'единении текстовых файлов, Вам желательно "разграничить" их данные, создав небольшую шапку, содержащую также имя файла, а после об'единения, исходные файлы необходимо ещё и удалить, то используйте следующую версию :
    Private Sub ConcatenateTextFiles4()
        Dim iPath$, iFileName$, iResult$, iText$, iHeader$
    
        iPath = "C:\Мои документы\Отчёты\5\"
        iResult = "Result_" & Date$ & ".txt"
        
        iHeader = vbCrLf & String(75, "*")
        iHeader = iHeader & vbCrLf & "FileName"
        iHeader = iHeader & vbCrLf & String(75, "*")
        iHeader = iHeader & vbCrLf
    
        iFileName = Dir(iPath & "*.txt")
        If iFileName <> "" Then
           Do
                Open iPath & iFileName For Input As #1
                     iText = iText & Application.Substitute( _
                     iHeader, "FileName", iFileName) & Input(LOF(1), #1)
                Close #1
                iFileName = Dir
           Loop While iFileName <> ""
           Kill PathName:=iPath & "*.txt"
           
           Open iPath & iResult For Output As #1
                Print #1, iText '
           Close #1
        End If
    End Sub
    Комментарий :
  • Удалённые файлы в корзину не помещаются, так что будьте внимательны и используйте этот макрос только, если Вы уверены в необходимости удаления файлов.
  • Обладатели Microsoft Excel 2000(или старше) вместо стандартной функции рабочего листа Application.Substitute могут использовать VB(A) функцию Replace

    Вариант II.
  • Private Sub MSDOS_ConcatenateTextFiles()
        Shell "Cmd.exe /C Copy C:\Имя_папки\*.txt C:\Result.txt", vbHide
        'Shell "Cmd.exe /C Copy ""C:\Имя Папки с пробелом\*.txt"" C:\Result.txt", vbHide   
    End Sub
    Источник : второй вариант написан на основании материалов, изложенных в данной справке.


  • Ответ :

    Если на Вашем компьютере установлен Microsoft Outlook (не путайте с Outlook Express) и эта программа используется для получения почты, то создать список непрочитанных писем из папки Входящие, можно просто выполнив нижеопубликованный макрос.
  • Private Sub CreateListUnReadMail()
        Dim objOutlook As Object, objNameSpace As Object
        Dim objFolder As Object, objMail As Object, iRow&
    
        Set objOutlook = CreateObject("Outlook.Application")
        Set objNameSpace = objOutlook.GetNamespace("MAPI")
        Set objFolder = objNameSpace.GetDefaultFolder(6) 'olFolderInbox
        
        Application.ScreenUpdating = False
        
        Workbooks.Add xlWBATWorksheet: iRow = 3
        
        For Each objMail In objFolder.Items
            If objMail.UnRead = True Then
               iRow = iRow + 1
               Cells(iRow, 1) = objMail.To
               Cells(iRow, 2) = objMail.SenderName
               Cells(iRow, 3) = objMail.Subject
               Cells(iRow, 4) = objMail.SentOn
               Cells(iRow, 5) = CBool(objMail.Attachments.Count)
            End If
        Next
        
        With Cells(3, 1).Resize(, 5) 'Range("A3:E3")
             .Value = Array("Кому", "От кого", "Тема", "Время", "Вложение")
             .Font.Bold = True
             .EntireColumn.AutoFit
        End With
        
        With Cells(1, 1).Resize(, 5) 'Range("A1:E1")
             .Merge
             .HorizontalAlignment = xlCenter
             .Value = "Microsoft Outlook - Папка Входящие (непрочитанные)"
             With .Font
                  .Bold = True
                  .Size = .Size + 2
             End With
        End With
        
        Application.ScreenUpdating = True: objOutlook.Quit
    End Sub

  • Ответ :

    Если Вам необходимо создать новую рабочую книгу .xls с определённым именем и в заранее указанной папке, то для решения такой задачи можно применить DAO (Data Access Objects). Пример можно найти на официальном сайте Microsoft, только обратите внимание, что перед использованием опубликованного там кода, необходимо подключить соответствующую ссылку (reference)

    How to Use DAO to Create a New Microsoft Excel Workbook

    Если страница на официальном сайте будет недоступна, то ознакомиться с её копией можно в Архиве Интернета
  • Ответ : Скачать пример

    Если Вам необходимо получить список всех видимых рабочих листов закрытой рабочей книги, то для решения такой задачи можно использовать DAO (Data Access Objects). Пример прилагается, только не забудьте указать реально существующий XLS файл, а также пароль, разумеется, если книга защищена паролем.
  • Private Sub DAO_GetNamesList()    
        Dim DAO As Object, DB As Object, TableDef As Object
        Dim iFileName$, iTableName$, iCount&
        
        iFileName = "C:\PriceCD.xls" 'Укажите свою существующую книгу
    
        Set DAO = CreateObject("DAO.DBEngine.35") ' "DAO.DBEngine.36"
        Set DB = DAO.OpenDatabase(iFileName, False, True, "Excel 8.0")
    
        For Each TableDef In DB.TableDefs
            iTableName = TableDef.Name
            If iTableName Like "*$" Then
               iCount = iCount + 1
               MsgBox iCount & ". " & Left(iTableName, Len(iTableName) - 1)
            End If
        Next
        
        DB.Close
    End Sub

  • Ответ : Скачать пример

    Если Вам необходимо отсортировать таблицу, используя только часть данных в столбце, причём без реального разделения данных и использования дополнительных ячеек, то для этого можно использовать SQL запрос.

    В качестве примера, рассмотрим случай, когда есть перечень ФИО в следующем виде :

    А.С.Пушкин
    Я.И.Брагин


    и нам необходимо отсортировать этот список по фамилиям и получить :

    Я.И.Брагин
    А.С.Пушкин


    В этом случае, обычная сортировка (без доп.действий) нам не поможет, поэтому :
  • Private Sub SortTableByFamily()
        Dim iTextQuery$, iTextConnect$
        iTextQuery = "SELECT * FROM [Таблица$A:D] ORDER BY MID(Фамилия,5)"
        iTextConnect = "ODBC;DSN=Excel Files;DBQ=" & ThisWorkbook.FullName
    
        With ActiveSheet.QueryTables.Add(iTextConnect, [A1], iTextQuery)
             '.HasAutoFormat = False 'Aктуально для Excel97
             .AdjustColumnWidth = False
             .RefreshStyle = xlOverwriteCells
             .Refresh BackgroundQuery:=False
             Names(.Name).Delete: .Delete
        End With
    End Sub
    Предполагается, что :
  • Таблица - это имя рабочего листа
  • A:D - исходный диапазон
  • A1 - первая ячейка диапазона. Если Вы укажите другую ячейку, то получите отсортированную "копию" исходного диапазона
  • Фамилия - Заголовок(шапка) столбца с фамилиями
  • 5 - Позиция символа, с которого начинаются данные для сортировки

    Комментарий : обладатели Microsoft Excel 97 обязательно должны закомментировать строку .AdjustColumnWidth = False и раскомментировать .HasAutoFormat = False
    Воспроизведение любых опубликованных здесь материалов возможно только с письменного разрешения автора : Microsoft Excel 95, 97, 2000, XP

  • © 2004-2017 Климов П.Ю. Все права защищены. WebDesign & Error's Klimoff