Microsoft Excel:

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


Rambler's Top100


Counter CO.KZ


    [1] [2] [3] [4] [5] [6]

  1. Как автоматически создать список, содержащий скопированный в буфер обмена текст ? NEW 05.11.2017
  2. Как автоматически создать архив всех изменений, для всех ячеек нужного рабочего листа ? NEW 04.02.2018
  3. Как после изменения данных, отменить все изменения, если хотя в одной из ячеек, количество символов превысит допустимое ? NEW 10.02.2018
  4. Как синхронизировать две и более ячейки ? NEW 10.05.2018
  5. Как разрешить пользователю вводить дату, где разделителем будет запятая ? NEW 10.06.2018
  6. Как разрешить пользователю вводить время, где разделителем будет запятая ? NEW 12.06.2018
  7. Как разрешить пользователю вводить дату, но без разделитей ? NEW 11.06.2018
  8. Как выбрать случайную ячейку из указанного диапазона ? NEW 21.05.2018
  9. Как сохранить данные ячеек, содержащих текст, в текстовый файл, причём данные ячеек, где использовался ALT+ENTER, необходимо также разбить по строкам ? NEW 01.07.2018
    [1] [2] [3] [4] [5] [6]


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

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

    Да, и обратите внимание, что копировать текст можно не только в Excel, проще говоря, пользователь может осуществлять копирование и в других программах. Однако в этом случае, если количество символов в скопированном тексте будет превышать 32767, то этот текст будет "разбит", ибо ячейка в Excel не может содержать большее количество символов.
  • 'Необходима следующая ссылка Microsoft Forms 2.0 Object Library
    
    Public iClipboard As New MSForms.DataObject, iRow&
    
    Public Sub StartCopyTextFromClipboard()
        Range("A:A").Clear
        CopyTextFromClipboard
    End Sub
    
    Public Sub CopyTextFromClipboard()
        If Application.ClipboardFormats(1) = xlClipboardFormatText Then
           iClipboard.GetFromClipboard
           iText$ = iClipboard.GetText(1)
           For iCount& = 1 To Len(iText$) Step 32767
               iRow& = iRow& + 1
               Cells(iRow&, 1) = Mid(iText$, iCount&, 32767)
           Next
           iClipboard.SetText "", 1
           iClipboard.PutInClipboard
        End If
        Application.OnTime DateAdd("s", 1, Now), "CopyTextFromClipboard"
    End Sub
    
    Public Sub StopCopyTextFromClipboard()
        On Error Resume Next
        Application.OnTime DateAdd("s", 1, Now), "CopyTextFromClipboard", , False
    End Sub

    Если же задача, в принципе, таже, но заполнять нужно только пустые ячейки конкретного диапазона (в примере это A1:C3), т.е. до выполнения макроса, некоторые ячейки уже могут быть заполнены и данные этих ячеек нужно оставить, а прекратить всё необходимо, как только все ячейки будут заполнены, то :
    'Необходима следующая ссылка Microsoft Forms 2.0 Object Library
    
    Public iClipboard As New MSForms.DataObject
    
    Public Sub CopyTextFromClipboard()
        Dim iSource As Range, iCell As Range, iText$
    
        On Error Resume Next
        iClipboard.GetFromClipboard: iText = iClipboard.GetText(1)
    
        If iText <> "" Then 'If Len(iText) > 0 Then
           Set iSource = ThisWorkbook.Worksheets(1).Range("A1:C3")
           Set iCell = iSource.Find("", , xlFormulas, xlWhole) ', xlByRows)
    
           If Not iCell Is Nothing Then
              iCell.Value = Left(iText, 32767)
              iClipboard.SetText "", 1: iClipboard.PutInClipboard
              Application.OnTime DateAdd("s", 1, Now), "CopyTextFromClipboard"
           End If
        End If
    End Sub

  • Ответ :

    Если Вам необходимо, чтобы после каждого изменения (ввод/редактирование/вставка/удаление) в любой из ячеек определённого рабочего листа, все изменения сохранялись в текстовый файл, то просто разместите нижеопубликованный код в модуле нужного рабочего листа [FAQ31]
  • Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        If Target.Count > 1 Then Exit Sub
        
        Open ThisWorkbook.Path & "\" & Target.Address For Append As #1
             Print #1, Now, Target.Value 'Target.Formula
        Close #1
    End Sub
    Комментарий : Обратите внимание на то, что данные каждой ячейки - сохраняются в свой(отдельный) текстовый файл. Причём, несмотря на отсутствие расширения, это именно текстовый файл, так что Вы можете просматривать его. Если же Вы считаете, что расширение обязательно необходимо, то просто добавьте к адресу ячейки & ".txt"

    Примечание : Если подобная архивация данных должна происходить только для ячеек определённого диапазона, то смотрите следующий совет [FAQ99]
  • Ответ : Актуально для MS Excel 97-2007

    Если Вам необходимо сразу после изменения данных (ввод, вставка скопированных/вырезаных данных) определить есть ли ячейка, где количество символов превышает максимально допустимое пользователем. И в случае наличия такой ячейки, отменить все произошедшие изменения, то разместите один из двух нижеопубликованных кодов в модуле нужного рабочего листа [FAQ31], только не забудьте указать свой лимит количества символов, в примерах, это 285
  • Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Dim maxLength As Variant
        maxLength = Evaluate("MAX(LEN(" & Target.Address(, , Application.ReferenceStyle) & "))")
        
        If IsError(maxLength) Then Exit Sub
        'Причин неудач(ошибки) может быть несколько :
        '1) В диапазоне есть ячейки, содержащие значение ошибки
        '2) Изменения произошли в диапазоне включающем целый столбец(ы)
            
        If maxLength > 285 Then
           Application.EnableEvents = False
           Application.Undo
           Application.EnableEvents = True
        End If
    End Sub
    Private Const LimitChar = 285
    
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Dim iSource As Range, iMask$
        iMask = String(LimitChar + 1, "?") & "*"
        
        For Each iSource In Target.Areas
            If Application.CountIf(iSource, iMask) > 0 Then
               Application.EnableEvents = False
               Application.Undo
               Application.EnableEvents = True
               Exit Sub
            End If
        Next
    End Sub
    Комментарий : Обратите внимание, на самом деле, оба варианта, определяют не количество символов в ячейке (свойство .Formula), а какое количество символов содержит значение ячейки (свойство .Value) Иначе говоря, если ячейка будет содержать формулу, например, =A1 а в ячейке A1 будет находиться этот комментарий, то количество символов в ячейке = 3 но оба варианта будут считать длину этого комментария, т.е. = 413

    Если сие неприемлимо и нужно ограничить именно количество символов в ячейке, то используйте третий вариант, не забывая, что метод Find не позволяет искать более 255 символов, а т.к. мы ищем на один символ больше, то наш лимит 254
    Private Const LimitChar = 100 'Максимум 254
    
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        If Not Target.Find(String(LimitChar + 1, "?"), , xlFormulas) Is Nothing Then
           Application.EnableEvents = False
           Application.Undo
           Application.EnableEvents = True
        End If
    End Sub

  • Ответ :

    Если Вам необходимо сихнхронизировать одну ячейку, т.е., сделать так, чтобы при любом изменении данных, например, в ячейке A1 = в C10 были те же данные, достаточно ввести в ячейку C10 ссылку =A1 и не устанавливать ручной пересчёт. Но если такой финт необходимо проделать для двух(и более) ячеек, то банальная ссылка не подойдёт. Впрочем, не всё так безнадежно, ибо можно разместить один из двух нижеопубликованных кодов в модуле нужного рабочего листа [FAQ31], не забывая указать ячейки,,которые необходимо синхронизировать и, разумеется, сохранить изменения.
  • Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Application.EnableEvents = False
        Select Case Target(1).Address
            Case "$A$1": [C10] = [A1] '[C10] = Target(1)
            Case "$C$10": [A1] = [C10] '[A1] = Target(1)
        End Select
        Application.EnableEvents = True
    End Sub
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Dim iSource As Range
        Set iSource = Intersect([A1,B1,C10], Target)
        If iSource Is Nothing Then Exit Sub
        
        Application.EnableEvents = False
        [A1,B1,C10] = iSource.Value
        Application.EnableEvents = True
    End Sub
    Комментарий : Обратите внимание на второй вариант, т.к. его проще адаптировать для трёх(и более ячеек). Кроме того, он не блокирует выполнение событий при каждом изменении в любой из ячеек рабочего листа.
  • Ответ :

    Если Вы привыкли вводить дату с использованием малой клавиатуры и хотите, вместо стандартных разделителей дня/месяца/года слэша, точки или тире, использовать запятую , т.е. 10,06,2018 ; 10,6,18 или просто 10,6 (если речь идёт о вводе даты текущего года), то разместите нижеопубликованный код в модуле нужного рабочего листа [FAQ31]
  • Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        If Target.Count > 1 Then Exit Sub
        
        iText$ = Replace(CStr(Target.Value2), ",", "/")
        If Not IsDate(iText$) Then Exit Sub
        
        Application.EnableEvents = False
        Target.NumberFormat = "dd/mm/yyyy"
        Target = CDate(iText$)
        Application.EnableEvents = True
    End Sub
    Примечание :
  • Если подобное преобразование должно происходить только в ячейках определённого диапазона, то смотрите следующий совет [FAQ99]
  • Если же преобразование необходимо производить во всех рабочих листах нужной рабочей книги, то используйте событие рабочей книги [FAQ172]
  • Ответ :

    Если Вы привыкли вводить время с использованием малой клавиатуры и хотите, вместо стандартнго разделителя часов:минут:секунд - двоеточия использовать запятую , т.е. 12,35 или 12,1,38 (если речь идёт также и о вводе секунд), то можно воспользоваться стандартной автозаменой. A чтобы эта замена не происходила во всех ячейках, макрос будет удалять автозамену, если пользователь выделил ненужные ячейки. Для этого, разместите нижеопубликованный код в модуле нужного рабочего листа [FAQ31] и укажите свой диапазон с временем. В примере это весь столбец A:A, но Вы можете указать другой, в т.ч. и несмежный, например, [A:A,F:F] или [A10:A102,C5,F5]
  • Private delAUItem As Boolean
    
    Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
        If Not Intersect(Target, [A:A]) Is Nothing Then
           'If delAUItem = True Then Exit Sub
           Application.AutoCorrect.AddReplacement ",", ":"
           delAUItem = True
        Else
           If delAUItem = True Then
              Application.AutoCorrect.DeleteReplacement ","
              delAUItem = False 'delAUItem = Not delAUItem
           End If
        End If
    End Sub
    Примечание : Маловероятно, но если Вы уже используете автозамену запятой на другой символ(ы), то вместо удаления, просто верните всё на круги своя. Т.е. замените Application.AutoCorrect.DeleteReplacement "," на (где ; это символ, на который необходимо заменить , ) Application.AutoCorrect.AddReplacement ",", ";"
  • Ответ :

    Если Вы не можете вводить дату с использованием стандартных разделителей дня/месяца/года слэша, точки или тире, и хотите вообще отказаться от их применения, т.е. для вводить 100618 или 50618 (только для дней от 1 до 9), то просто разместите нижеопубликованный код в модуле нужного рабочего листа [FAQ31]
  • Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        If Target.Count > 1 Then Exit Sub
    
        iText$ = CStr(Target.Value2)
        If iText$ Like "#####*" Then
           iText$ = Format(iText$, "00\.00\.00")
           If IsDate(iText$) = True Then
              Application.EnableEvents = False
              Target.NumberFormat = "dd/mm/yy"
              Target = CDate(iText$)
              Application.EnableEvents = True
           End If
        End If
    End Sub
    Примечание :
  • Если подобное преобразование должно происходить только в ячейках определённого диапазона, то смотрите следующий совет [FAQ99]
  • Если же преобразование необходимо производить во всех рабочих листах нужной рабочей книги, то используйте событие рабочей книги [FAQ172]
  • Ответ :

    Для того, чтобы выбрать случайную ячейку, из указанного диапазона, в примере это [A1:C3], достаточно об'единить два уже опубликованных совета :
  • Randomize 'Timer
    
    With Range("A1:C3")
         MsgBox .Cells(Int((Rnd * .Count) + 1))
    End With
    Randomize 'Timer
    
    With Range("A1:C3")
         MsgBox .Cells(Int((Rnd * .Count) + 1))
    End With
    Разумеется, VB(A) функция MsgBox используется только в качестве демонстрации, но если Вы не знаете как адаптировать этот пример для работы с об'ектными переменными, то :
    Dim iSource As Range, iCell As Range
    Set iSource = Range("A1:C3")
    
    Randomize 'Timer
    
    Set iCell = iSource(Int((Rnd * iSource.Count) + 1))
    

  • Ответ :

    Если Вам необходимо сохранить данные ячеек, содержащих текст, в текстовый файл. Причём, текст тех ячеек, где использовался ALT+ENTER необходимо также "разбить" по строкам, то воспользуйтесь любым из нижеопубликованных макросов :
  • Private Sub SaveVerticalText1() 'XL2000
        Dim iFileName$, iCell As Range
        iFileName = Replace(ActiveWorkbook.FullName, ".xls", ".txt")
        
        Open iFileName For Output As #1
             For Each iCell In ActiveSheet.UsedRange. _
                 SpecialCells(xlConstants, xlTextValues)
                 Print #1, Replace(iCell, vbLf, vbCrLf)
             Next
        Close #1
    
        ActiveWorkbook.FollowHyperlink iFileName 'Для наглядности
    End Sub
    Private Sub SaveVerticalText2() 'XL2000
        Dim iFileName$, iCell As Range, tmp As Variant
        iFileName = Replace(ActiveWorkbook.FullName, ".xls", ".txt")
    
        Open iFileName For Output As #1
             For Each iCell In ActiveSheet.UsedRange. _
                 SpecialCells(xlConstants, xlTextValues)
                 For Each tmp In Split(iCell.Value, vbLf)
                     Print #1, tmp
                 Next
             Next
        Close #1
    
        ActiveWorkbook.FollowHyperlink iFileName 'Для наглядности
    End Sub

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

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