Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 14 След.
После добавления пользовательской функции сильно тормозит Excel
 
Цитата
flower написал:
можно ли что-то сделать
1. У вас есть необъявленная переменная "OutText"
2. Не используйте свойства языка vba (тут: "TextRange") в качестве имен переменных
3. Измените текстовую переменную ("OutText"), которая создает конкатенацию, на переменную массива (конечно, вам нужно изменить код функции)
Может такое изменение в чём-то поможет ... (?)
Как сохранить в буфер обмена - объект, чье название вписано в ячейку B1
 
Может так ?

Код
Sub xyz()
    
    On Error Resume Next
        With Sheets("List1")
            .Shapes(Application.Trim(.Range("B1").Value)).Copy
        End With
        
        If Err.Number <> 0 Then MsgBox "Tut nichego net - konets": Exit Sub
    On Error GoTo 0
    
    With Sheets("List2")
        .Paste Destination:=.Range("A1")
    End With
    
    Application.CutCopyMode = False
    
End Sub
Как из ячейки имеющей общий формат и содержащую Дату и Время вырезать Время, оставив только датуЭ с помощью VBA?
 
Цитата
Юрий М написал:
дата остаётся
"Ничто" не остаётся - у меня это не дата и время, а "простой текст".
Не для всех "точка" является разделителем даты.
"Application.International(xlDateSeparator)" => и всё становится проще
[ Закрыто] Группировка цифр, сгруппировать по порядку, сцепить ячейки
 
А можно макросом ?
Удалить дубликаты строк
 
:)
Второй (длинный) вариант этой ручной работы:
Во-первых, сортировка по возрастанию в столбце "А"
Потом в ячейке "B1": "=A1=A2" => скопировать формулу вниз
Дальше, преобразование формул в результаты
Затем замена "True/Правда/Истина" пустым текстом (Ctrl+H)
Потом Ctrl+G => "Специальные" => "Пустые ячейки" => OK
Дальше, "Удалить" => "Вся строка" => OK
В конце, пиво ...
Удалить дубликаты строк
 
Цитата
DJMC написал:
вопрос  дубликаты.xls
Какая версия Excel ?
У вас есть файл "xls" - значит ли это 2k3 ?
Прогнозы при кризисе
 
бывает, бывает ... когда умирает большинство пожилых и больных людей
ведь это они потребляют большую часть лекарств
и если они "уйдут" так и рынок падает до нуля
а здоровых не лечиться ... может просто только из похмелья
Ограничение доступа на запуск макроса
 
Цитата
Salta-301 написал:
вместо прописания всех ячеек
А может так ?
Код
Sub aaa()
    If Not verifyuser(Environ("UserName")) Then MsgBox "Stoy, predyavi propusk !": End
    MsgBox "Aaa, Vkhodite pozhaluysta ! Proshu Vas, zakhodite !"
End Sub

Function verifyuser(strStr As String) As Boolean
    verifyuser = False
    If IsError(Application.Match(strStr, Sheets("md").Columns("H"), 0)) Then Exit Function
    verifyuser = True
End Function

'ili

Sub bbb()
    If IsError(Application.Match(Environ("UserName"), Sheets("md").Columns("H"), 0)) Then _
    MsgBox "Stoy, predyavi propusk !": End
    MsgBox "Aaa, Vkhodite pozhaluysta ! Proshu Vas, zakhodite !"
End Sub
Вопрос по функции SUMIF
 
минимум 3 способами
Ссылка на ячейку из ComboBox
 
Цитата
chotop написал:
... ссылку на значение ... из comboBox, а не само значение ...
?
Код
Option Explicit

Private skipthis As Boolean

Private Sub UserForm_Initialize()
    Const tblnme = "tab_A"
    Const col = "A"
    
    Dim r As Long, arr As Variant
    
    skipthis = True ' Chtoby opustit 'cmbBox_Change' (i drugiye) vo vremya initsializatsii 'UserForm1'
    
    With Sheet2.ListObjects.Item(tblnme).DataBodyRange.Columns(col)
        ReDim arr(1 To .Rows.Count, 1 To 2)
        For r = .Cells(1, 1).Row - 1 To .Rows.Count
            arr(r, 1) = .Cells(r, 1).Value
            '(0, 0)=>"=Sheet2!A2"/ (1, 0)=>"=Sheet2!A$2"/ (0, 1)=>"=Sheet2!$A2"/ ()=>"=Sheet2!$A$2"
            arr(r, 2) = "='" & .Parent.Name & "'!" & .Cells(r, 1).Address(1, 0)
        Next
    End With
    
    With UserForm1
        .Caption = "Okno"
        With .cmbBox
            .BoundColumn = 1 ' '.Value' in ComboBox
            '.TextColumn = 2 ' '.Text' in ComboBox => no ne tut !
            .ColumnCount = 1 ' Tolko pervaya kolonka
            .List() = arr: arr = Empty
            .ListIndex = -1
        End With
    End With
    
    skipthis = False
End Sub

Private Sub cmbBox_Change()
    If skipthis = True Then Exit Sub
    '...
End Sub

Private Sub btnSave_Click()
    With Sheet1
        With .Range("A1,A10,A22")
            'Application.EnableEvents = False ' ???
                .Formula = Me.cmbBox.Column(1, Me.cmbBox.ListIndex)
                '.Offset(0, 1).Value = Me.cmbBox.Value ' Tolko dlya testov => zakommentirovat
            'Application.EnableEvents = True ' ???
        End With
    End With
End Sub
?
Персонализация письма в VBA
 
... если сработало, это хорошо, рад что помог.
Персонализация письма в VBA
 
Цитата
Salta-301 написал:
вставить имя из ячейки D2 Sheets("Main")
...
xOutMsg = "<p style='font-family:ARIAL;font-size:22'><b>Добрый день, & Recipient &
Может так (?), если это должен быть Html (?)
Код
xOutMsg = "<html><body><p style=""font-family:'Arial';font-size:22pt;""><b>" & _
          Sheets("Main").Range("D2").Text & "</b><br>" & _
          Sheets("Main").Range("D3").Text & "</p></body></html>"
Как можно организовать передачу значений переменных между процедурами.
 
Цитата
Фарит написал:
вставлять таблицы результатов ... переменная npp-номер строки не передает свое значение другой процедуре
Есть также ещё такой вариант, что если ваша "передача переменных" больше связана с какими-то вычислениями, лучше использовать функции, которые будут вычислять правильные "вещи".
Код
Sub aaa()
    With Sheets("List1")
        .Range("B1").Value = funktsiya(.Range("A1").Value)
    End With
End Sub

Function funktsiya(peremenna)
    If Not IsNumeric(peremenna) Then
        funktsiya = "Ya byl tut v 'A1' -> 'Yeti, 2019'"
        Exit Function
    End If
    
    Dim rslt
    
    Select Case peremenna
        Case 0:         rslt = 0
        Case 1 To 9:    rslt = (peremenna * 5) + 24 - 1
        Case Else:      rslt = (peremenna * 5) + 1 - 4
    End Select
    
    funktsiya = rslt
End Function
Скриптом открыть файл, изменить и записать
 
"Select" предназначен только для активного объекта (тут: "Приложение 5.xlsx" и какой-то лист), так как объект в данный момент неактивен (тут: "Лист1" в "ThisWorkbook"), это будет ошибка выполнения команды ("Select").
Скриптом открыть файл, изменить и записать
 
:)
Код
Option Explicit

Sub meowky_meowky_meow()
    Const srcSht = "List1", srcRngBeg = "A1", srcCol1 = 3, srcCol2 = 1
    Const trgSht = "List2", trgRngBeg = "A1"
    Const fltr = "All XLS Files (*.xls*),*.xls*,XLS Files (*.xls),*.xls,XLSX Files (*.xlsx),*.xlsx"
    Const fltrind = 1
    '-----------------------------------------------------------------------------------
    Dim srcvar: srcvar = Application.GetOpenFilename(fltr, fltrind, "Select SOURCE file", , False)
    Application.Wait (Now + TimeValue("00:00:01"))
    Dim trgvar: trgvar = Application.GetOpenFilename(fltr, fltrind, "Select TARGET file", , False)
    If srcvar = False Or trgvar = False Then Exit Sub
    '-----------------------------------------------------------------------------------
    Dim srcWkb: srcWkb = Right(Trim(srcvar), Len(Trim(srcvar)) - InStrRev(Trim(srcvar), Application.PathSeparator, -1, 1))
    Dim trgWkb: trgWkb = Right(Trim(trgvar), Len(Trim(trgvar)) - InStrRev(Trim(trgvar), Application.PathSeparator, -1, 1))
    If srcWkb = trgWkb Then Exit Sub
    If srcWkb = ThisWorkbook.Name Or trgWkb = ThisWorkbook.Name Then Exit Sub
    srcWkb = Empty: trgWkb = Empty
    '-----------------------------------------------------------------------------------
    Set srcWkb = Workbooks.Open(Filename:=srcvar, UpdateLinks:=0, ReadOnly:=True)
    Set trgWkb = Workbooks.Open(Filename:=trgvar, UpdateLinks:=0, ReadOnly:=False)
    srcvar = Empty: trgvar = Empty
    '-----------------------------------------------------------------------------------
    With srcWkb
        With .Sheets(srcSht)
            With .Range(srcRngBeg).CurrentRegion
                srcvar = .Offset(1, srcCol1 - 1).Resize(.Columns(srcCol1).Rows.Count - 1, 1).Value
                trgvar = .Offset(1, srcCol2 - 1).Resize(.Columns(srcCol2).Rows.Count - 1, 1).Value
            End With
        End With
        .Close False
    End With
    Set srcWkb = Nothing: srcWkb = Empty
    '-----------------------------------------------------------------------------------
    With trgWkb
        With .Sheets(trgSht)
            .Select
            With .Range(trgRngBeg)
                With .Cells(.CurrentRegion.Rows.Count, 1)
                    .Select
                    .Offset(1, 0).Resize(UBound(srcvar, 1), 1).Value = srcvar
                    .Offset(1, 1).Resize(UBound(trgvar, 1), 1).Value = trgvar
                End With
            End With
        End With
    End With
    srcvar = Empty: trgvar = Empty
    Set trgWkb = Nothing: trgWkb = Empty
    '-----------------------------------------------------------------------------------
    With ThisWorkbook
        .Saved = True
        .Close False
    End With
End Sub
:)  
Скрытие строк в зависимости от содержания ячеек
 
Цитата
noobie1 написал:
надеюсь
... ой ... "Надежда" ... значит у вас есть "UserForm", а не объект в листе ... а напишите пожалуйста ещё как называется лист со строками до скрытия.
По коде видно что это другой лист, не "Профиль сотрудника", иначе вы бы скрывали строки с этими ячейками: А3, А4, А5 ... ну, а зачем бы это делать ?
И как/когда/каким действием эти скрытые строки должны быть заново раскрыты/открыты или это должно работать только в одну сторону ?
Скрытие строк в зависимости от содержания ячеек
 
Опишите точнее, какие строки и когда (в каких ситуациях) надо скрывать или раскрывать ?
Что это за объекты эти "OptionButtons": Formants, ActiveX (OLEObjects) ?
Ничего не известно ... : (
Автоматическая смена строки при вводе данных
 
Аналогичный вариант, как указано выше:
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count > 1 Then Exit Sub
    On Error GoTo 0
    If Intersect(Target, Range("A:E")) Is Nothing Then Exit Sub
    If Target.Row = 1 Then Exit Sub
    If Target.Column = 5 Then
        Target.Offset(1, -4).Select
    Else
        Target.Offset(0, 1).Select
    End If
End Sub
Изменено: ocet p - 21 апр 2020 19:51:10
Объединенить / СЦЕПИТЬ ячееки в умной таблице, macro, vba
 
Цитата
Alex D написал:
End колонки постоянно меняется от листа к листу
Значит,  это надо сделать для многих листов, а не только для одного ?
Объединенить / СЦЕПИТЬ ячееки в умной таблице, macro, vba
 
8) Вы написали этот код, и не знаете, как это сделать дальше ? 8)  ... вот шутник из вас ...  ;)  
Перенос количества определенных ячеек на другой лист
 
Если я правильно понял, например, так:
Код
Option Explicit

Sub abc_xyz()
    With Sheets("List2")
        With .Range("F" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(.Range("C1").Value, 1)
            .Value = Sheets("List1").Range("I1:I" & .Parent.Range("C1").Value).Value
        End With
    End With
    With Sheets("List1")
        With .Rows("1:" & Sheets("List2").Range("C1").Value)
            .Delete
        End With
    End With
End Sub
Удаление объектов (Shape) находящихся в конкретном диапазоне листа.
 
Цитата
БМВ написал:
Это мы с Дмитрием обсудили
Я не всё прочитал ... признаю ...

Цитата
БМВ написал:
будут строки вставляться
Что с 'Shape.Placement Property' ?

Цитата
БМВ написал:
Intersect(Shape.TopLeftCell, Cell)
Не будет ли лучше (?):
Код
If Intersect(cell, Range(shp.TopLeftCell, shp.BottomRightCell)) ...
тогда или "перед" или "зад" могут выступать за ячейку



Редакт.

??? прямо по имени ???
Код
Sub udali_kartinku_balbinku()
    Dim i%, idx%, j%, jdx%
    Dim diap, kart
    
    diap = Array("A", "B", "F", "K")
    idx = UBound(diap)
    kart = Array(1, 4, 5, 7, 9, 10, 12, 13, 17, 24)
    jdx = UBound(kart)
    
    With Sheets("List1")
        For i = 0 To idx
            For j = 0 To jdx
                .Shapes(diap(i) & "_" & kart(j) & "_kart").Delete
            Next
        Next
    End With
End Sub
Изменено: ocet p - 21 фев 2020 00:39:09
Удаление объектов (Shape) находящихся в конкретном диапазоне листа.
 
Цитата
БМВ написал:
при наличии множества объектов, оптимально найти и удалить один или несколько объектов
Если имя фигуры будет содержать адрес ячейки, в которую была вставлена ​​эта фигура, то найти и удалить её будет очень легко - только, вам нужно сначала навести порядок (уладить, упорядочить) в именах фигур.
Выбор из текста в ячейке данных по конкретным парметрам
 
Цитата
Аналитик2 написал:
50:20:0030102:1858, площадью 59,4 кв.м., кв. 138, адрес
... несогласованность/несоответствие данных ... : ( ... в то же время и десятичный разделитель и разделитель списка ... : (
Ошибка 1004 при вставке текста в объединенную ячейку
 
Если у вас есть, например, объединенная ячейка "С5" ("С5:Е8"), то попробуйте это:
Код
Sub clop_plank()
    With ThisWorkbook
        .Activate
        With .Worksheets("List1")
            .Select
            With .Range("C5")
                If .MergeCells Then .MergeArea.UnMerge
                .Select
            End With
            ActiveSheet.PasteSpecial Format:="HTML", link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
            Application.CutCopyMode = False
            'With .Range("B11:C14").Interior
            '    .Pattern = xlSolid
            '    .PatternColorIndex = xlAutomatic
            '    .Color = 65280
            '    .TintAndShade = 0
            '    .PatternTintAndShade = 0
            'End With
            .Range("B22").Select
        End With
    End With
End Sub
Ошибка 1004 при вставке текста в объединенную ячейку
 
?
Ну ... и вот так должно быть с объединенными ячейками
?

А в чем вам нужна помощь ?
Можно ли группировать строки по номерам
 

Посмотрите пожалуйста тут:

https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=124283&a...

код gling - не подходит (?), ведь можно модифицировать ...

Функция сжать пробелы макросом (VBA)
 
Цитата
Andrey Ka написал:
данные в виде цифр
В виде (= формате) или просто это числа ?

? Replace() ?
Построчно прочитать текстовый файл с кириллицей в utf-8, вывести его содержимое на листе.
 
Цитата
elegi2003 написал:
файл достаточно большой, а мне нужны не все подряд строки, а только некоторые
Зачем сразу не написали ?
Так каков размер этого файла, что он не подходит excel ?
Попробуйте так, но вы не предоставили достаточно информации о файлах для обработки:
Код
Option Explicit

Sub utfe_8()
    Const fltr = "CSV Files (*.csv),*.csv,TXT Files (*.txt),*.txt"
    '--------------------------------------------------------------
    ' https://docs.microsoft.com/en-us/sql/ado/reference/ado-api/stream-object-ado?view=sql-server-ver15
    ' ADODB.Stream
    '--------------------------------------------------------------
    'Charset => HKEY_CLASSES_ROOT\MIME\Database\Charset
        Const chrst = "utf-8"
    'StreamTypeEnum
        Const adTypeBinary = 1
        Const adTypeText = 2
    'SaveOptionsEnum
        Const adSaveCreateNotExist = 1
        Const adSaveCreateOverWrite = 2
    'StreamWriteEnum
        Const adWriteChar = 0
        Const adWriteLine = 1
    'StreamReadEnum
        Const adReadAll = -1 ' The default value
        Const adReadLine = -2
    'LineSeparatorsEnum
        Const adCR = 13
        Const adLF = 10
        Const adCRLF = -1
    '--------------------------------------------------------------
    Dim fle
    fle = Application.GetOpenFilename(fltr, 2, "UTF-8", , False)
    If TypeName(fle) = "Boolean" Then Exit Sub
    'fle = "C:\Temp\PrimerUTF-8.txt"
    'fle = Right(fle, Len(fle) - InStrRev(fle, "\", -1, 1))
    '--------------------------------------------------------------
    Dim r&, strline, utf8 As Object
    '--------------------------------------------------------------
    Set utf8 = CreateObject("ADODB.Stream")
    utf8.Type = adTypeText
    utf8.Charset = chrst
    utf8.LineSeparator = adCRLF
    utf8.Open
    'utf8.LoadFromFile ThisWorkbook.Path & "\" & fle
    utf8.LoadFromFile fle
    '--------------------------------------------------------------
    utf8.Position = 0 ' posle 'LoadFromFile' ne obyazatel'no
    '--------------------------------------------------------------
    Do Until utf8.EOS
        strline = utf8.ReadText(adReadLine)
        If Trim(strline) <> "" Then
            If strline Like "##." Or strline Like "*####*" Then
                'MsgBox Left(strline, 32)
                '???
            Else
                r = r + 1
                Range("A" & r).Value = Application.Clean(strline)
            End If
        End If
    Loop
    '--------------------------------------------------------------
    utf8.Close
    Set utf8 = Nothing
End Sub

Работает с тестовым файлом:
Построчно прочитать текстовый файл с кириллицей в utf-8, вывести его содержимое на листе.
 
Почему макрос ?
Например:
Данные => Импорт из текстового файла => Кодирование 65001 (UTF _ 8 .)
Изменено: ocet p - 8 фев 2020 01:36:40
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 14 След.
Наверх