Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Пользователи » andreyka33
Выбрать дату в календаре…Выбрать дату в календаре

Страницы: 1 2 3 4 След.
Поиск строки по артикулу через TextBox
 
#
14.07.2019 16:32:25
Еще раз благодарю
3 варианта получается во вложении
 
Перейти    
Поиск строки по артикулу через TextBox
 
#
14.07.2019 16:24:04
Благодарю Ігор Гончаренко и Sanja - за то что помогли !
Проверил - макрос Игоря работает нормально, а вот макрос Sanja к сожалению не заработал как надо.

Файл с обоими макросами во вложении
 
Перейти    
Поиск строки по артикулу через TextBox
 
#
14.07.2019 15:26:17
Задача- поиск в диапазоне Range("A4:M" & lr).Value путем скрытия строк - если в строке в ячейках диапазона нет значения поиска.Если в строке есть значение поиска по частичному совпадению - то строка остается видимой, если нет то скрывается строка). Тк таблица будет большой под 2-3 тыс записей  (будет пополнятся постоянно) лучше сделать через массив - что и пытаюсь сделать. Пример выше.
 
Перейти    
Поиск строки по артикулу через TextBox
 
#
14.07.2019 13:15:49
дак я файл пример приложил выше и все написал - еще раз
Дело в том что при
arr() = Range("B1:B" & lr).Value - все  корректно ищет и скрывает строки - но только по столбцу B (а не по всему  диапазону A4:M таблицы) - строки со значениями поиска видимы, строки  без значений поиска скрыты
При
arr() = Range("A4:M" &  lr).Value - все некорректно идет - не работает как надо - нужные строки  со значениями поиска скрыты, а строки без значений поиска видимы
Код
Sub Поиск()
    Dim strText As String, arr()
    Dim lr As Long, i As Long
    Application.ScreenUpdating = False
    Rows.Hidden = False
    strText = ActiveSheet.OLEObjects("Textbox1").Object.Text
    If strText = "" Then
        Application.ScreenUpdating = True
        Exit Sub
    End If
    lr = Cells(Rows.Count, "A").End(xlUp).Row
'    arr() = Range("B1:B" & lr).Value
    arr() = Range("A4:M" & lr).Value
    For i = 4 To UBound(arr)
        If InStr(1, arr(i, 1), strText, vbTextCompare) = 0 Then
            Rows(i).Hidden = True
        End If
    Next i
    Application.ScreenUpdating = True
End Sub
 
Перейти    
Поиск строки по артикулу через TextBox
 
#
14.07.2019 09:24:02
С find работает ниже код нормально - но предполагается что в таблице будет 2-3 тыс строк - наверно тупить будет
Поэтому вопрос выше с массивами актуален - как же его переделать чтоб корректно работал ?
Код
Sub ПоискУчетДокументов()
Dim lr As Long, x
Dim ra As Range, ТекстДляПоиска As String
Application.ScreenUpdating = False

    Rows.Hidden = False
    ТекстДляПоиска = ActiveSheet.OLEObjects("Textbox1").Object.Text ' показываем строки с таким текстом
    If ТекстДляПоиска = "" Then
        Application.ScreenUpdating = True
        Exit Sub
    End If
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    ' перебираем все строки в используемом диапазоне листа
    For Each ra In ActiveSheet.Range("A4:M" & lr).Rows
        ' если в строке найден искомый текст
    If Not ra.Find(ТекстДляПоиска, , xlValues, xlPart) Is Nothing Then
        ra.EntireRow.Hidden = False 'показываем строки
        Else 'иначе
        ra.EntireRow.Hidden = True 'скрываем строки
    End If
    Next
    
    
Application.ScreenUpdating = True
End Sub
 
Перейти    
Поиск строки по артикулу через TextBox
 
#
14.07.2019 01:21:19
если использовать вариант от Sanja - то точно такая же ситуация в этом коде - некорректно работает с arr = Range("A4:M" & lr).Value, корректно с arr = Range("B1:B" & lr).Value и по части слова (текста) не работает
Код
Sub Поиск()
Dim strText As String, arr()
    Dim lr As Long, i As Long, j As Long
    Application.ScreenUpdating = False
    Rows.Hidden = False
    strText = ActiveSheet.OLEObjects("Textbox1").Object.Text
    If strText = "" Then
        Application.ScreenUpdating = True
        Exit Sub
    End If
    lr = Cells(Rows.Count, "A").End(xlUp).Row
'    arr = Range("B1:B" & lr).Value
    arr = Range("A4:M" & lr).Value
    For i = 4 To UBound(arr, 1) 'цикл по строкам
        For j = 1 To UBound(arr, 2) 'цикл по столбцам
            If arr(i, j) = strText Then
            Rows(i).Hidden = False
            Else
            Rows(i).Hidden = True
            End If
        Next
    Next
Application.ScreenUpdating = True
End Sub
Изменено: andreyka33 - 14.07.2019 09:25:22
 
Перейти    
Поиск строки по артикулу через TextBox
 
#
13.07.2019 23:03:12
ничего не понял пока - в общем выкладываю файл с примером и код
Код
Sub Поиск()
    Dim strText As String, arr()
    Dim lr As Long, i As Long
    Application.ScreenUpdating = False
    Rows.Hidden = False
    strText = ActiveSheet.OLEObjects("Textbox1").Object.Text
    If strText = "" Then
        Application.ScreenUpdating = True
        Exit Sub
    End If
    lr = Cells(Rows.Count, "A").End(xlUp).Row
'    arr() = Range("B1:B" & lr).Value
    arr() = Range("A4:M" & lr).Value
    For i = 4 To UBound(arr)
        If InStr(1, arr(i, 1), strText, vbTextCompare) = 0 Then
            Rows(i).Hidden = True
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Дело в том что при
arr() = Range("B1:B" & lr).Value - все корректно ищет и скрывает строки - но только по столбцу B (а не по всему диапазону A4:M таблицы) - строки со значениями поиска видимы, строки без значений поиска скрыты
При
arr() = Range("A4:M" & lr).Value - все некорректно идет - не работает как надо - нужные строки со значениями поиска скрыты, а строки без значений поиска видимы
 
Перейти    
Поиск строки по артикулу через TextBox
 
#
13.07.2019 20:48:09
те както If InStr(1, arr(i, 1), strText, vbTextCompare) = 0 Then переделать ?
 
Перейти    
Поиск строки по артикулу через TextBox
 
#
13.07.2019 20:24:54
ищу макрос поиска со скрытием строк и поиску по части слова в диапазоне таблицы - набрел на эту тему
слепил макрос - вроде все ищет и работает  Только одна заминка - сейчас ищет только в диапазоне arr() = Range("E1:E" & lr).Value
lr = Cells(Rows.Count, "A").End(xlUp).Row
а  как сделать чтобы искал так arr() = Range("A4:M" & lr).Value ?  - но так не прокатывает
те в массив arr() както надо загнать значения диапазона ячеек Range("A4:M" & lr).Value  (а не одного столбца)
макрос рабочий прилагаю
Код
'************************************************************************************
'Макрос ПОИСКА на листе 
'************************************************************************************
Sub ПоискУчетДокументов()
'    Dim strText As String, arr()
    Dim strText As String
    Dim arr() As Variant
    Dim lr As Long, i As Long, x
    Application.ScreenUpdating = False
    Rows.Hidden = False
    strText = ActiveSheet.OLEObjects("Textbox1").Object.Text
    If strText = "" Then
        Exit Sub
    End If
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    MsgBox lr
    arr() = Range("E1:E" & lr).Value
    For i = 4 To UBound(arr)
        If InStr(1, arr(i, 1), strText, vbTextCompare) = 0 Then
            Rows(i).Hidden = True
            Else
            Rows(i).Hidden = False
            Cells(i, 2).Select
        End If
    Next i
    Application.ScreenUpdating = True
End Sub
 
Перейти    
Отображение формата процентов в ListBox
 
#
11.07.2019 23:57:44
Заработало  - благодарю Sanja за помощь !
 
Перейти    
Отображение формата процентов в ListBox
 
#
11.07.2019 23:05:55
тоже не прокатило
Код
With Me.ListBox1
    For i = 0 To 5
    .List(i, 0) = FormatPercent(.List(i, 0))
Next i
End With
 
Перейти    
Отображение формата процентов в ListBox
 
#
11.07.2019 22:55:32
да все нормально - закомментируйте часть  все нормально отображается - но дробными числами (не процентами в ListBox)
Код
'    With Me.ListBox1
''      For i = .ListCount - 1 To 0 Step -1
'      For i = 0 To 5
''         .List(i, 0) = (Format(.List(i, 0), "0%"))
'          .List(i, 0) = Percent(.List(i, 0))
'      Next i
'    End With
Изменено: andreyka33 - 11.07.2019 22:56:47
 
Перейти    
Отображение формата процентов в ListBox
 
#
11.07.2019 22:42:04
прикладываю
 
Перейти    
Отображение формата процентов в ListBox
 
#
11.07.2019 22:25:14
К сожалению ошибку пишет на Percent  типа Sub or Function not defined  - не пркатывает почемуто строка с Percent
Изменено: andreyka33 - 11.07.2019 22:26:21
 
Перейти    
Отображение формата процентов в ListBox
 
#
11.07.2019 22:12:48
Добрый вечер всем !

Столкнулся с проблемой - значения ячеек в формате % некорректно отображаются в ListBox формы
в ячейке например 10%  - в ListBox отображается 0,10
в ячейке например 25%  - в ListBox отображается 0,25

Пробую загнать в форму код
Код
Private Sub UserForm_Initialize()
Dim  i As Long
With Me.ListBox1
'      For i = .ListCount - 1 To 0 Step -1
      For i = 0 To 5
         .List(i, 0) = (Format(.List(i, 0), "0%"))
      Next i
End With
  

отображать начинает шестизначные числа и пр - как можно правильно наладить в ListBox отображение % ?
 
Перейти    
Ввод уникального неповторяющегося номера строки по условию
 
#
11.07.2019 20:25:48
Благодарю RAN за помощь !
 
Перейти    
Ввод уникального неповторяющегося номера строки по условию
 
#
11.07.2019 20:24:33
хм так заработало
Код
Function Мяу&()
    Мяу = Application.Max((Sheets("УчетДокументов").Columns(1)), (Sheets("Выполнено").Columns(1)))
End Function

Sub ПронумероватьСтолбецА()
Application.ScreenUpdating = False 'чтоб не моргало выключаем скрин
 Application.EnableEvents = False

 Dim i As Long, LastRow As Long
 LastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Cells(LastRow + 1, 1).Select
 Cells(LastRow + 1, 1).Value = Мяу + 1
 'Cells(LastRow + 1, 1).Value = ..... макрос выбора уникального номера ....
 


Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub
 
Перейти    
Ввод уникального неповторяющегося номера строки по условию
 
#
11.07.2019 20:21:00
Чегото не заработало корректно

Код
Function Мяу&()
    Мяу = Application.Max((Sheets(1).Columns(1)), (Sheets(2).Columns(1)))
End Function

Sub ПронумероватьСтолбецА()
Application.ScreenUpdating = False 'чтоб не моргало выключаем скрин
 Application.EnableEvents = False

 Dim i As Long, LastRow As Long
 LastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Cells(LastRow + 1, 1).Select
 Cells(LastRow + 1, 1).Value = Мяу
 'Cells(LastRow + 1, 1).Value = ..... макрос выбора уникального номера ....
 


Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub
 
Перейти    
Ввод уникального неповторяющегося номера строки по условию
 
#
11.07.2019 19:59:53
Добрый вечер всем !
В книге 2 листа: лист "УчетДокументов" и лист "Выполнено"
В столбце А обоих листов находится нумерация строк - при этом нумерация уникальна:
те на обоих листах нет повторяющихся (одинаковых) номеров

Как на листе "УчетДокументов" в столбце А в первую незаполненную ячейку внести уникальный номер по условию:
собрать все номера внесенные на обоих листах в столбце А, вычислить последний самый больший номер N и присвоить в новую строку
номер N+1  ?

Макрос начал делать - но пока только определение 1 незаполненной ячейки
Код
Sub ПронумероватьСтолбецА()
Application.ScreenUpdating = False 'чтоб не моргало выключаем скрин
 Application.EnableEvents = False

 Dim i As Long, LastRow As Long
 LastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Cells(LastRow + 1, 1).Select
 
 'Cells(LastRow + 1, 1).Value = ..... макрос выбора уникального номера ....
 


Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Файл с примером прилагаю.
 
Перейти    
Нестрогий поиск - не учитывать спецсимволы и пробелы
 
#
10.06.2019 19:59:39
Дмитрий все заработало - еще раз благодарю за помощь!
 
Перейти    
Нестрогий поиск - не учитывать спецсимволы и пробелы
 
#
10.06.2019 19:31:37
Так сделал  - но ошибку дает на строке arr(i, 1) = DelTrash(arr(i, 1))  типа  ByRef argument type mismatch
Код
Function DelTrash(s$)
    Dim aToFind, li&, res$
    aToFind = Array(Chr(34), " ", ".", ",", "'", "\") 'Chr(34) = кавычка
    res = s
    For li = LBound(aToFind) To UBound(aToFind)
        res = Replace(res, aToFind(li), "")
    Next
    DelTrash = res
End Function


Sub Поиск ()
    Dim strText As String, arr()
    Dim lr As Long, i As Long, x
    Rows.Hidden = False
    strText = ActiveSheet.OLEObjects("Textbox1").Object.text
    If strText = "" Then
        Exit Sub
    End If
   strText = DelTrash(strText)
    lr = Cells(Rows.Count, "B").End(xlUp).Row
    arr() = Range("B1:B" & lr).Value
    For i = 4 To UBound(arr)
       arr(i, 1) = DelTrash(arr(i, 1))
        If InStr(1, arr(i, 1), strText, vbTextCompare) = 0 Then
            Rows(i).Hidden = True
            Else
            Rows(i).Hidden = False
        End If
    Next i
     
    x = dhCountVisibleCells(Range("A5:S500"))
    If x = 0 Then
    Rows.EntireRow.Hidden = False
    MsgBox "Текст не найден !"
    Else
'    ActiveWindow.ScrollColumn = 8
    End If
End Sub
 
Перейти    
Нестрогий поиск - не учитывать спецсимволы и пробелы
 
#
10.06.2019 19:08:20
Благодарю - буду пробовать отпишусь как результат
 
Перейти    
Нестрогий поиск - не учитывать спецсимволы и пробелы
 
#
10.06.2019 17:35:47
День добрый всем !

Есть макрос поиска по InStr- нашел на просторах инета приспособил под свои нужды
По значению TextBox1 ищет совпадающие значения в столбце B и показывает нужные строки с совпадающими значениями (остальные скрывает)
Код
Sub Поиск ()
    Dim strText As String, arr()
    Dim lr As Long, i As Long, x
    Rows.Hidden = False
    strText = ActiveSheet.OLEObjects("Textbox1").Object.text
    If strText = "" Then
        Exit Sub
    End If
    lr = Cells(Rows.Count, "B").End(xlUp).Row
    arr() = Range("B1:B" & lr).Value
    For i = 4 To UBound(arr)
        If InStr(1, arr(i, 1), strText, vbTextCompare) = 0 Then
            Rows(i).Hidden = True
            Else
            Rows(i).Hidden = False
        End If
    Next i
    
    x = dhCountVisibleCells(Range("A5:S500"))
    If x = 0 Then
    Rows.EntireRow.Hidden = False
    MsgBox "Текст не найден !"
    Else
'    ActiveWindow.ScrollColumn = 8
    End If
End Sub

Вопрос в том что нужно сделать нестрогий поиск - исключить спецсимволы (кавычки, точки, тире и пр) и лишние пробелы (не дожны учитываться при поиске)
те както модифицировать строку
Код
If InStr(1, arr(i, 1), strText, vbTextCompare) = 0 Then

чтоб не учитывал при поиске регистр,спецсимволы и лишние пробелы ?
Например: в TextBox1 строка для поиска:  Шкаф     Белый
найдет  шкаф "белый"
 
Перейти    
Выравнивание текста в TextBox формы по вертикали
 
#
26.05.2019 18:09:08
Доброго дня всем !

Как выровнять текст в TextBox формы по вертикали - только по горизонтали есть
Наткнулся на код в форму на ресурсе  Здесь
Код выглядит так
Код
Private Type RECT
        Left   As Long
        Top   As Long
        Right   As Long
        Bottom   As Long
End Type
Private Declare Function SendMessage Lib "user32 " Alias "SendMessageA " ( _
        ByVal hwnd As Long, _
        ByVal wMsg As Long, _
        ByVal wParam As Long, _
        lParam As Any) As Long
Private Const EM_GETRECT = &HB2
Private Const EM_SETRECTNP = &HB4

Sub VerMiddleText(mText As TextBox)
        If mText.MultiLine = False Then Exit Sub
        Dim rc     As RECT, tmpTop       As Long, tmpBot       As Long
        SendMessage mText.hwnd, EM_GETRECT, 0, rc
        With Me.Font
            .Name = mText.Font.Name
            .Size = mText.Font.Size
            .Bold = mText.Font.Bold
        End With
        tmpTop = ((rc.Bottom - rc.Top) - _
                (mText.Parent.TextHeight("H ") \ Screen.TwipsPerPixelY)) \ 2 + 2
        tmpBot = ((rc.Bottom - rc.Top) + _
                (mText.Parent.TextHeight("H ") \ Screen.TwipsPerPixelY)) \ 2 + 2
        rc.Top = tmpTop
        rc.Bottom = tmpBot
        mText.Alignment = vbCenter
        SendMessage mText.hwnd, EM_SETRECTNP, 0&, rc
        mText.Refresh
End Sub

Private Sub Form_Load()
        VerMiddleText (text1)
End Sub

Только не понял как запустить  - непонятен этот кусок
Код
Private Sub Form_Load()
        VerMiddleText (text1)
End Sub

Заменил на это
Код
Private Sub UserForm_Activate()
Dim text1 As String
text1 = TextBox1.Value
VerMiddleText (text1)
End Sub

MultiLine в True поставил
Но выдает ошибку на переменную text1
Как поправить код чтоб работал ?

Файл приложил с примером
 
Перейти    
Вставить скопированную строку на защищенном листе макросом
 
#
22.05.2019 19:28:43
Попробовал так сделать на основе макросов выше  - вроде работает но время от времени случайным образом ругается на rhgForCopy.Copy
Код
Dim rhgForCopy
Public arr()

Sub ВырезатьКонтент_2_без_формата()
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.Unprotect Password:="88"

arr = ActiveCell.EntireRow.Value
Set rhgForCopy = ActiveCell.EntireRow
ActiveCell.EntireRow.Select
ActiveCell.EntireRow.ClearContents

ActiveSheet.Protect Password:="88", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
Application.EnableEvents = True
'Application.ScreenUpdating = True
End Sub

Sub ВставитьКонтент_и_Формат_2()
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.Unprotect Password:="88"

rhgForCopy.Copy
ActiveCell.EntireRow.Select
Range("a" & ActiveCell.Row).Resize(1, UBound(arr, 2)).Value = arr
Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteFormats 'вставить только формат исходной строки
'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
'Rows(ActiveCell.Row).PasteSpecial

ActiveSheet.Protect Password:="88", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
Application.EnableEvents = True
'Application.ScreenUpdating = True
End Sub
 
Перейти    
Вставить скопированную строку на защищенном листе макросом
 
#
22.05.2019 17:47:21
формат исходной строки не трогаем - вырезаются только значения
а в новую строку попадают вырезанные значения из исходной строки и копируется формат исходной строки
Изменено: andreyka33 - 22.05.2019 17:49:07
 
Перейти    
Вставить скопированную строку на защищенном листе макросом
 
#
22.05.2019 17:02:57
sokol92 к сожалению ваш вариант выдает ошибку на строке rngForCopy.Copy

Нужны рекомендации по следующему коду - не хочет работать:  вырезать только значения (формат исходной строки не трогаем)  и  вставить в новую строку  значения и все форматы исходной строки. Стандартный Cut  не подходит - он вырезает формат исходной строки.
Ошибка на строке ActiveSheet.Paste ( причем без строки rhgForCopy.ClearContents макрос нормально работает как простое копирование)
Код
Dim rhgForCopy

Sub ВырезатьКонтентСтроки()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="88"
       Set rhgForCopy = ActiveCell.EntireRow
       ActiveCell.EntireRow.Select
    ActiveSheet.Protect Password:="88", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
    Application.EnableEvents = True
    'Application.ScreenUpdating = True
End Sub
 
 
Sub ВставитьФормат_и_КонтентИсхСтроки()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="88"
      ActiveCell.EntireRow.Select
      rhgForCopy.Copy
      rhgForCopy.ClearContents
      'ActiveCell.EntireRow.ClearContents
     'On Error Resume Next
      ActiveSheet.Paste
     'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteAll
     'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
     'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValues
     'Rows(ActiveCell.Row).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
     'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Protect Password:="88", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
    'On Error GoTo 0
    Application.EnableEvents = True
    'Application.ScreenUpdating = True
End Sub
Изменено: andreyka33 - 22.05.2019 17:04:35
 
Перейти    
Вставить скопированную строку на защищенном листе макросом
 
#
21.05.2019 15:15:52
Благодарю еще раз Ivan.kh за помощь !
Добавил строку еще ActiveCell.EntireRow.Select  - чтоб визуально выделялось
Код
Dim rhgForCopy

Sub КопироватьСтроку()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="123"
    Set rhgForCopy = ActiveCell.EntireRow
    ActiveCell.EntireRow.Select
    ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
    Application.EnableEvents = True
    'Application.ScreenUpdating = True
End Sub


Sub ВставитьСтроку()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="123"
    rhgForCopy.Copy
    ActiveCell.EntireRow.Select
    'Selection.Locked = False
    'On Error Resume Next
    'ActiveSheet.Paste
    'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteAll
    'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValues
    'Rows(ActiveCell.Row).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
    'On Error GoTo 0
    Application.EnableEvents = True
    'Application.ScreenUpdating = True
End Sub
 
Перейти    
Вставить скопированную строку на защищенном листе макросом
 
#
21.05.2019 14:33:28
Благодарю Ivan.kh и Nordheim - оба варианта работают !    Только правда еще одна проблемка - корректно ВЫРЕЗАТЬ строку - ВСТАВИТЬ строку не получается на защищенном листе   попробую с учетом ваших вариантов
 
Перейти    
Вставить скопированную строку на защищенном листе макросом
 
#
21.05.2019 13:41:25
Все нормально копирует - в макросе закомментируйте все защиту и при снятой защите все прекрасно работает - только что перепроверил
Пытливый - ваш совет к сожалению не помог
Изменено: andreyka33 - 21.05.2019 13:47:18
 
Перейти    
Страницы: 1 2 3 4 След.
Наверх