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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 След.
Выбор диапазона ячеек макроса через userform/combobox
 
Цитата
Baguza написал:
Range("F10:F9999"))      -      вот этот код чтобы можно было выбирать через combobox
Поясните пожалуйста, это всегда должен быть диапазон "F10:F9999" или тоже какой-то другой внутри него ?
Макрос взаимного перевода сантиметров в дюймы. Пересчет при переходе на любую ячейку
 
Цитата
Павел Иванов написал:
но не так
А что для вас значит "в любую ячейку" и каким должен быть результат работы этого макроса ?
Макрос взаимного перевода сантиметров в дюймы. Пересчет при переходе на любую ячейку
 
А что должно быть индикатором, в каком направлении должна происходить конверсия ?
На данный момент это номер столбца, в котором была выбрана ячейка.

Может быть так ?
Код
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
    On Error GoTo konets
        If Not IsNumeric(Target.Cells(1, 1).Value) Then Exit Sub
        Application.EnableEvents = False
        [A2].Value = Round(Target.Cells(1, 1).Value / 2.54, 2)
        [B2].Value = Round(Target.Cells(1, 1).Value * 2.54, 2)
konets: Application.EnableEvents = True
End Sub
Изменено: ocet p - 8 Дек 2019 19:22:23
Копирование ячеек, по заполняемости ячеек. На разные листы.
 
Например:
(имена листов должны совпадать с названиями месяцев в заголовках таблицы)
Код
Option Explicit

Sub abc_xyz()
    Dim c%, cl%, r&, rw&, nr&
    Dim sh As Worksheet
    
    With ThisWorkbook
        Set sh = .Sheets("ГОД")
        rw = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
        cl = 15
        
        For c = 4 To cl
            With .Sheets(sh.Cells(7, c).Value) ' названия месяцев <=> заголовки таблицы
                '.Select
                nr = 6
                For r = 8 To rw
                    If Trim(sh.Cells(r, c).Value) <> "" Then
                        .Range("A" & nr & ":D" & nr).Value = Array(nr - 5, sh.Cells(r, "B").Value, sh.Cells(r, "C").Value, sh.Cells(r, c).Value)
                        nr = nr + 1
                    End If
                Next
            End With
        Next
        
        Set sh = Nothing
    End With
    
    MsgBox "Сделано"
End Sub
Выгрузка данных из Excel в несколько txt-файлов.
 
Вы это имели ввиду ?
Код
Sub WriteSERVICE(control As IRibbonControl)
    '...
    Next
    
    Dim dostup$
    dostup = Trim(InputBox("Pozhaluysta, vvedite bukvu stolbtsa s putem k katalogu", "Put' k faylam", "B"))
    If dostup = "" Then Exit Sub
    
    ss = ThisWorkbook.Path & Application.PathSeparator
    ss = ss & Cells(3, dostup).Value & "_" & Format(Now, "dd-mm-yy-hh-mm-ss") & "_SERVICE" & ".txt"
    
    n = FreeFile
    Open ss For Output As #n
    Print #n, s
    Close #n
    '...
End Sub


пс:
Код
Set wsUnload = ActiveSheet
Нужно ли это? Через несколько строк у вас есть это (без 'ActiveSheet' ... и без '.Value' тоже):
Код
& Cells(3, 2) &
далее
Код
wsUnload.Cells(wsUnload.Rows.Count, 7).Value
Последняя ячейка столбца "G" ("G65536" или "G1048576"), почему и зачем ?
Код
wsUnload.Rows.Count
Все строки листа, почему и зачем ?
Изменено: ocet p - 8 Дек 2019 03:23:49
Выделение с помощью УФ по наличию разных слов в ячейке
 
Цитата
astranet написал: Не сработало
Цитата
Юрий М написал: запятую на точку с запятой
... или:

Скопируйте это:

Код
[B1].Value = "=NOT((COUNTIF(A1,""*sale*"")+COUNTIF(A1,""*order*"")))"


Откройте Excel:

1. затем нажмите Alt + F11
2. затем нажмите Ctrl + G
3. и в появившемся окне ("Immediate") вставьте то, что было скопировано
4. мигающий курсор мыши должен находиться сразу за скопированным текстом, если нет, поместите его в скопированный текст
5. нажмите "Enter"

В ячейке "B1" должна появиться формула в русской версии.

Выделение с помощью УФ по наличию разных слов в ячейке
 
Таким образом ?
(Я не силен в функциях, но кажется, что это должно работать)
Код
=NOT((COUNTIF(A1,"*sale*")+COUNTIF(A1,"*order*")))
Макрос сохранения из Excel в PDF с защитой полученного PDF от копирования контента
 
Цитата
Alexey V написал:
В полученном pdf картинка копируется простым выделением мыши
Вы можете использовать программу печати PDF (например, PDFCreator):

1. Вы сохраняете XLS в PDF - печатая xls на принтере PDF
2. Тот же документ перепечатываете на PDF-принтере
3. Изображение может быть скопировано, но оно все чёрное

Макрос сохранения из Excel в PDF с защитой полученного PDF от копирования контента
 
Цитата
Alexey V написал:
при этом получившийся pdf был защищен от копирования
По моему этот Pdf сохраните снова в Pdf - но это не изменит тот факт, что вы всё ещё можете сделать снимок экрана и вся защита ... знаете ...!!!@*&^%??*$^@^!!!... ну да ... OCR, хакер махер комбинатор ... и так дальше ...  :)  
Как в макросе перейти на ячейку по ссылке указанной в формуле?
 
:)  ... вот шутники

Код
Option Explicit

Sub bezhi_do_yezhi_1()
    Dim pos%, r&, nzvLista$, adrYach$, frmla, prmtr             ' Ob"yavleniya peremennykh
    r = 2                                                       ' Nachinayem so vtoroy stroki
    With Sheets("Svodnaya")                                     ' na liste "Svodnaya"
        Do Until .Cells(r, "C").Value <> "a"                    ' Poka w yacheykakh bukva "a"
            r = r + 1                                           ' bezhit' po stolbtsy "C"
        Loop                                                    '
        frmla = .Cells(r, "C").Formula                          ' Poluchayet formulu iz yacheyki
    End With
    pos = InStr(1, frmla, "!", 1)                               ' Opredelyayet polozheniye vosklitsatel'nogo znaka "!"
    nzvLista = Mid(frmla, 2, pos - 2)                           ' Vydelyayet nazvaniye lista "Raschet"
    adrYach = Mid(frmla, pos + 1, Len(frmla) - pos)             ' Vydelyayet adres yacheyki "K12"
    prmtr = Sheets(nzvLista).Range(adrYach).Offset(0, 1).Value  ' Poluchayet parametr
    MsgBox prmtr
End Sub

Sub bezhi_do_yezhi_2()
    Dim r&, frmla, prmtr
    r = 2
    With Sheets("Svodnaya")
        Do Until .Cells(r, "C").Value <> "a"
            r = r + 1
        Loop
        frmla = .Cells(r, "C").Formula
    End With
    'Mid(frmla, 2, Len(frmla) - 1) = "Raschet!K12" => "=OFFSET("Raschet!K12",0,1,1,1)"
    prmtr = Evaluate("Offset(" & Mid(frmla, 2, Len(frmla) - 1) & ", 0, 1, 1, 1)")
    MsgBox prmtr
End Sub
Поиск одинаковых слов в строке
 
Цитата
dsg написал:
чтобы данные вышли в отдельную колонку
dsg, вы поблагодарили меня ни за что ... так, от меня, что-то такое, может подойти вам для чего-то (?):
Код
Option Explicit

Sub abc()
    Dim txt$, i&, r&, arr
    r = 2
    arr = Array("!", "@", "#", "$", "%", "^", "&", "*", "(", ")", "_", "-", "+", "=", "\", "/", "|", "?", "<", ">", _
                "~", "`", ",", ".", ":", ";", """", "'", "{", "[", "}", "]") '=> ??? eto dlya sluchaya takikh fraz kak 'Triol' i '/TRIOL/'
    Do Until Trim(Cells(r, "A").Value) = ""
        txt = Application.Trim(Cells(r, "B").Text)
        For i = 0 To UBound(arr)
            txt = Replace(txt, arr(i), "", 1, -1, 1)
        Next
        Cells(r, "C").Value = abc_xyz(txt)
        r = r + 1
    Loop
End Sub

Function abc_xyz(txt$)
    Dim rslt$, tmp$, ar, pos
    ar = Split(txt, " ", -1, 1)
    Do While UBound(ar) > -1
        tmp = ar(0)
        ar(0) = ""
        pos = Application.Match(tmp, ar, 0)
        If Not IsError(pos) Then
            rslt = IIf(rslt = "", tmp, rslt & "; " & tmp) '<=zdes' vy mozhete izmenit' razdelitel' pri neobkhodimosti
            Do While Not IsError(pos)
                ar(pos - 1) = ""
                pos = Application.Match(tmp, ar, 0)
            Loop
        End If
        ar = Split(Application.Trim(Join(ar, " ")), " ", -1, 1)
    Loop
    abc_xyz = rslt
End Function

У меня (для латиницы) это работает.
Поиск одинаковых слов в строке
 
dsg, как у БМВ выше и ещё то:
Цитата
БМВ написал:
и задача переходит в уровень VBA

... и совсем в не так простой ...
Выделить (извлечь, экстрагировать) слова не проблема, проблема состоит в том, чтобы проверить, какие комбинации слов образуют фразу.
Что если, например есть такая "вещь":
(извините "за иностранный акцент" ... :) ... это только вольна / свободна / привольна (?) интерпретация - легче писать без хорошего владения языком)

"Прошэк '300 гр дла' ко 'кошэк бэз' млэка 'дла кошэк бэз' хлэба потрошэ за '300 гр'"

Что тут будет фразой, а что нет:

1. "300 гр дла" и "дла кошэк бэз" => мы дублируем "для" ?
или
3. "300 гр дла" и "кошэк бэз"
или
2. "300 гр" и "дла кошэк бэз"

или ещё по другому если возможно ?

Ошибка вычисления внутри ЕСЛИ()
 
... ещё долго, это правда

Как вам удалось установить количество нулей после десятичной запятой до 36, для числового формата в "C1/D1" ?
"Обычно" это только 30 (я имею дело со старыми версиями: 2k3, 2k7), или может быть, в новых "Excel" этот параметр расширенный ?

Редакт.:
Ну да ... не посмотрел на пользовательский формат ... : (

А как с этим делом справится у вас это (функция ОТБР = TRUNC ?) ?
Код
Sub abc_xyz()
    Range("C4").Formula = "=TRUNC(C1,36)" ' => ??? 'ОТБР' ???
    Range("D4").Formula = "=TRUNC(D1,36)" ' => ??? 'ОТБР' ???
    Range("E4").Formula = "=IF(ISBLANK(D4),""ОШИБКА"",C4-D4)"
    Range("E5").Formula = "=C4-D4"
    Range("G4").Formula = "=C4=D4"
    Range("E5,G4").NumberFormat = "General"
End Sub
Изменено: ocet p - 1 Дек 2019 02:52:18
Ошибка вычисления внутри ЕСЛИ()
 
Итак, пришло время использовать установления точности в соответствии с "отображаемой точностью":
Файл \ Параметры \ Дополнительно \ "При пересчете этой книги:” => ставить флажок "задать точность как на экране"
:)
https://support.office.com/ru-ru/article/%D0%97%D0%B0%D0%B4%D0%B0%D0%BD%D0%B8%D0%B5-%D1%82%D0%BE%D1%...
Множественная замена в большом диапазоне., зависает Excel при выполнении макроса
 
ой там ... :x ... в данном случае тоже ... автор всё равно и так будет рыться в коде, пусть у него будет меньше того рытья, пусть всё "в одном месте" будет а и попрактикует в выборе элементов из переменных массива ... но можно это и поменять, если это чья-то воля:
Код
    rplc = Array(Chr(10), "<*b*>", "[*spoiler*]", "[*i*]")
    rplcmnt = "<p>" ' Array("<p>", "<p>", "<p>", "<p>")
    '...
        .Replace What:=rplc(i), Replacement:=rplcmnt
    '...
... но это выглядит так как-то не "симметрично" ... : (
Множественная замена в большом диапазоне., зависает Excel при выполнении макроса
 
... и такие там другие модификации к модификациям ...
Код
Sub Re_Move_Carrie_Age()
    Dim i%, xTitleId$, rplc, rplcmnt, workRng
    
    xTitleId = "Title"
    
    rplc = Array(Chr(10), "<*b*>", "[*spoiler*]", "[*i*]")
    rplcmnt = Array("<p>", "<p>", "<p>", "<p>")
    
    On Error Resume Next
        workRng = Application.InputBox("Range", xTitleId, Selection.Address, Type:=8).Address
        If workRng = Empty Then Exit Sub
    On Error GoTo 0
    
    With Range(workRng)
        For i = 0 To UBound(rplc)
            .Replace What:=rplc(i), Replacement:=rplcmnt(i), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
        Next
        
        .Value = Application.Trim(.Value)
        .Value = Application.Clean(.Value) ' ???
    End With
End Sub
Ошибка вычисления внутри ЕСЛИ()
 
Более ещё ... теперь измените формат "1 минуты" ("B1") на общий, войдите в режим редактирования "F2" и нажмите "Enter" ... и всё стало "истинной правдой".
Значит, "форматирование вредно для здоровья" пользователя Excel ...  :)  
Ошибка вычисления внутри ЕСЛИ()
 
В ячейках "C1" и "D1" есть разные значения.
Это выглядит так как будто файл пришёл из преобразования от какого-то другого "Excela".
Запуск макроса Outlook из Excel
 
"Как не палочкой в него, так может камушком ?"   :)
Второй суррогат:

Excel - Module1:
Код
Option Explicit

Const pth$ = "C:\Program Files\Microsoft Office\OfficeXY\OUTLOOK.EXE"
Const strpath$ = "C:\Temp\AgentExcel.txt"

Sub para_ersatz_surrogat()
    Dim prmtr: prmtr = "Parametr iz Excel z " & Now
    '...
    Dim nmbr As Byte: nmbr = FreeFile(0)
    Open strpath For Output Access Write Lock Write As #nmbr
    Print #nmbr, prmtr
    Close #nmbr
    '
    Dim x: x = Shell(pth, vbNormalFocus)
End Sub

Outlook - ThisOutlookSession:
Код
Option Explicit

Const strpath$ = "C:\Temp\AgentExcel.txt"

Private Sub Application_Startup()
    If Dir(strpath, vbNormal) = "" Then Exit Sub
    Dim prmtr$, nmbr As Byte: nmbr = FreeFile(0)
    Open strpath For Input Access Read Lock Read As #nmbr
    Line Input #nmbr, prmtr
    Close #nmbr
    Kill strpath
    Call Mak1(prmtr)
End Sub

Public Sub Mak1(Optional prmtr = "Net parametra iz Excel")
    MsgBox prmtr
End Sub

pth и strpath - Вы определяете это сами
Запуск макроса Outlook из Excel
 

Кажется, что это не работает ... и не будет (?) ... попробуйте суррогат:

ThisOutlookSession:

Код
Private Sub Application_Startup()
    Call makro1
End Sub

Public Sub makro1()
    MsgBox "1"
End Sub

Excel:

Код
Sub abc_xyz()
    Dim x
    x = Shell("C:\Program Files\Microsoft Office\OfficeXY\OUTLOOK.EXE", vbNormalFocus)
End Sub

"C:\Program Files\Microsoft Office\OfficeXY\OUTLOOK.EXE"

(или любой другой путь доступа, если пользовательский)

где XY - версия вашего Office

Вписать формулу по типу "сцепить" макросом, Часть формулы нужно брать из ячейки
 
По моему:
1. Если «FormulaR1C1» - то не используйте формат типа «B2 / $B$2», только типа «R2C2 / R[2]C[2]»
2. Если не «FormulaLocal» только «Formula / FormulaR1C1», то используйте английские вместо русских названий / имен функций
Ошибка в логике макроса при множественном выборе из выпадающего списка
 
Немножко неясная "потребность", покажите пожалуйста, на примере, 3 результата выбора 3 разных значений (первое, среднее, последнее) из списка проверки в ячейках столбца 'B', может быть тогда кто-то "склонится" над этим. На данный момент попробуйте "поиграть", например, с: 'Validation.Formula1', 'Split/Join', 'Filter', 'Transpose' ...
Вложенный цикл для другой книги
 
Цитата
Argo9 написал:
Я ведь это делаю или на активном листе или через блок with

Но я имел в виду другую часть кода:

Код
1. Set prom = Workbooks.Open("C:\Users\Gumin-AA\Desktop\sever.xlsx")
2. Set svod = Workbooks.Open("C:\Users\Gumin-AA\Desktop\ugeas.xlsm")
3. Set reestr = svod.Sheets("jenk")
4. Set zakl = prom.Sheets("Лист1")
5. Set otkl = prom.Sheets("Лист3")
 
6. lLastRow = Cells(Rows.Count, 1).End(xlUp).Row

1. первая открытая книга => "sever.xlsx"
2. вторая открытая книга => "ugeas.xlsm" - она становится актуальной, активной

3. это важный момент => 'Sheets("jenk")'

(4, 5). здесь не важно

6. это важный момент => <<Cells(Rows.Count, 1) >> такая запись относится к активному листу в активной книге, а активной (по коду) есть "ugeas.xlsm"

Есть ли в этой книге только один лист: "jenk" ?
Если нет, а листов больше, то какова уверенность, что этот лист будет активным после открытия книги а количество строк будет правильно рассчитано для правильного листа ?

Цитата
Hugo написал:
GetObject() бывало косячил
Нормально, в vba всегда найдётся что-то, что будет "косячить" ... :)

Изменено: ocet p - 22 Ноя 2019 04:39:17
Множественный выбор переключателй, ToogleButton
 
Может так ?
Код
Option Explicit

Sub Tam_i_naoborot()
    Dim ctrl As Object
    
    '...
    For Each ctrl In ActiveSheet.OLEObjects
        If TypeOf ctrl.Object Is ToggleButton Then ctrl.Object.Enabled = Not ctrl.Object.Enabled
    Next
    '...
End Sub
Вложенный цикл для другой книги
 
Цитата
Argo9 написал:
подскажите как реализовать работу
1. Проверьте дату в начале, зачем открывать файлы, если кто-то вводит неправильную дату и генерирует ошибки выполнения кода ?
2. Вместо "Workbooks.Open" используйте "GetObject("C:\Users\Gumin-AA\Desktop\какой-то файль")"
3. Вы не активируете/не указываете необходимого листа для расчёта "lLastRow" в своём коде.
   У вас есть "lLastRow = Cells(Rows.Count, 1).End(xlUp).Row"
   С какого листа рассчитывается 'lLastRow': "Лист1" или "Лист2" или "Лист3", ... или там только один лист "jenk" ?
   Что если кто-то сохранит файл с выбранным неверным листом (если больше чем один) и после открытия не будет того, который нужен ?
   
Как выделить цветом столбец с фильтром
 
... или таким образом ... срабатывать будет при 'Calculation Event' ('Событие расчёта' ?), но нужна ещё будет ячейка с гашеткой (триггером) - функция «SUBTOTAL» для автофильтра:
Код
Private Sub Worksheet_Calculate()
    Call abc_xyz
End Sub

Sub abc_xyz()
    With ActiveSheet
        If .AutoFilterMode Then
            Range("A1").CurrentRegion.Interior.Color = xlNone
            If .AutoFilter.FilterMode Then
                Dim i%, fltr
                For Each fltr In .AutoFilter.Filters
                    i = i + 1
                    If fltr.On Then Range("A1").CurrentRegion.Columns(i).Interior.Color = RGB(87, 240, 26)
                Next
            End If
        Else
            Range("A1").CurrentRegion.Interior.Color = xlNone
        End If
    End With
End Sub
Как проверить наличие директории не сбивая функцию Dir?
 
Зачем вам нужен "Dir", если вы используете "FSO" ?
Правильное создание двумерного массива из произвольных столбцов плоской таблицы в VBA
 
Может это что то подобное ?
Код
Option Explicit

Sub abc_xyz()
    Dim rws&, tbl()
    Range("M1").CurrentRegion.ClearContents
    rws = Cells(Rows.Count, "A").End(xlUp).Row
    tbl = Application.Index(Range("A1:K11"), Application.Evaluate("Row(1:" & rws & ")"), Array(2, 4, 7))
    Range("M1").Resize(UBound(tbl), 3) = tbl
End Sub
Получить тип данных, записанных в ячейке
 
Цитата
Glago написал:
Теперь на выходе даёт стринг
Код
Sub Data_type_Data()
    ' 'TypeName' provides information about a variable
    [K2] = TypeName([B2]) '=> 'Range' => object subtype
    [K3] = TypeName([G2]) '=> 'Range' => object subtype
    
    ' 'VarType' indicates the subtype of the variable
    [L2] = VarType([B2]) '=> '8' => 'String'
    [L3] = VarType([G2]) '=> '8' => 'String'
    
End Sub

;)  
Изменено: ocet p - 17 Ноя 2019 20:45:36
Проблема stdole32.tlb внезапно появилась в Excel, Прошу помощи
 
Цитата
iiiadan написал:
Сразу же остановился на строчке Код ? 1Set wa = CreateObject("Word.Application")
У меня, код RAN работает ... :) ... мяу, мяу ...
Какие есть системные и офисные версии у вас ? Я имею в виду, всё ли 32-bit или 64-bit, или например Office 32-bit а Windows 64-bit ? Может быть, причина кроется в несовместимости программного обеспечения.

...

Редакт.:

может быть это поможет (?):

https://appuals.com/fix-microsoft-excel-2007-error-stdole32-tlb/
https://answers.microsoft.com/en-us/msoffice/forum/msoffice_excel-mso_other-mso_2007/stdole32tlb-in-...
Изменено: ocet p - 17 Ноя 2019 17:47:30
Страницы: 1 2 3 4 5 6 7 8 9 10 11 След.
Наверх