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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 След.
Множественный выбор переключателй, 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
Проблема stdole32.tlb внезапно появилась в Excel, Прошу помощи
 

Здравствуйте iiiadan - Такие идеи у меня:

Идея 1. Приложите пример всего вашего "Excel"-Word-макроса
или
Идея 2. Удалите Office и переустановите его
или
Идея 3. Попробуйте изменить процедуру "запусков" и запускайте Word из Excel, а не Excel из Word
или
Идея 4. Сценарий VBS запускает документ Word со своим макросом, затем сохраняет данные в текстовом-CSV файле на диск, затем закрывает документ Word, затем открывает CSV-файл в Excel

Удалить часть текста (слова состоящие из заглавных букв)
 
Не мне ... :) ... только Кузьмичу скажите спасибо за это, я был просто редактором его кода ... и не знаю, хорошим или плохим.
Копирование файлов в разные папки по списку
 
и не только это ... было бы несколько других дел ... а теперь например это:
Код
Option Explicit

Sub abc_xyz()
    Const pth_src$ = "C:\Temp\0_Source\"    ' <== !!! Iskhodnyy katalog
    Const pth_trgt$ = "C:\Temp\0_Target\"   ' <== !!! Katalog naznacheniya
    Const dltr$ = "|"                       ' Razdelitel'
    
    'Net iskhodnogo kataloga, net raboty !!!
    If Dir(pth_src, vbDirectory) = "" Then MsgBox "Net iskhodnoy papki - Konets 'filma'": Exit Sub
    
    'Otsutstvuyet katalog naznacheniya ? Budet sozdan
    If Dir(pth_trgt, vbDirectory) = "" Then MkDir pth_trgt
    
    Dim ext$, flnme$, flpth$, fls, i&, ind&, r&: r = 2
    
    Do Until Trim(Cells(r, "A").Value) = ""
        flpth = pth_trgt & Trim(Cells(r, "A").Value) & "\"
        fls = Split(Application.Trim(Cells(r, "B").Value), dltr, -1, 1)
        ind = UBound(fls)
        
        'Otsutstvuyet katalog naznacheniya ? Budet sozdan
        If Dir(flpth, vbDirectory) = "" Then MkDir flpth
        
        For i = 0 To ind
            'Iskhodnyy fayl sushchestvuyet v iskhodnom kataloge, tak nachinayem rabotat'
            If Dir(pth_src & fls(i), vbNormal) <> "" Then
                'Fayl uzhe sushchestvuyet v kataloge i meshayet nam ? Delayem kopiyu etoy "meshalki-meshatelya"
                If Dir(flpth & fls(i), vbNormal) <> "" Then
                    ext = Split(fls(i), ".", -1, 1)(UBound(Split(fls(i), ".", -1, 1)))
                    'Tol'ko odna tochka v imeni fayla, inache budet oshibka !!!
                    flnme = Split(fls(i), ".", -1, 1)(UBound(Split(fls(i), ".", -1, 1)) - 1)
                    On Error Resume Next
                        'Kopiya fayla budet sdelana tol'ko odin raz !!!
                        Name flpth & fls(i) As flpth & flnme & "_old." & ext
                        If Err.Number <> 0 Then
                            MsgBox "Kopii predydushchikh faylov uzhe sushchestvuyut v kataloge !" & vbCrLf & _
                            "Sdelayte poryadok v svoikh faylakh !" & vbCrLf & "Konets 'filma'"
                            End
                        End If
                    On Error GoTo 0
                End If
                FileCopy pth_src & fls(i), flpth & fls(i)
            End If
        Next
        
        r = r + 1
    Loop
End Sub
Удалить часть текста (слова состоящие из заглавных букв)
 
Попробуйте заменить:
Код
.Pattern = "[A-Z \d]+\b"
на
Код
.Pattern = "[A-Z. \d+]+ \b"

Вы можете также составить себе список исключённых слов и использовать простой макрос с методом "Replace" и циклом, например "For ... Next"
... или вручную "Ctrl+H" ... (?) ... если немного слов для обмена.

пс:
Простите (любознательному коту ... :) ... ), зачем в вашем файле такой странный "пиджин" польско-германский ?
VBA FileFilter поправить для записи Текстового файла с табуляцией
 
Пожалуйста попробуйте:
Код
Option Explicit

Const iFileName As String = "C:\Temp\redkl.txt"
Const rRng As String = "A1:D1000"

Sub abc_xyz()
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
        Dim iSource As Range
        Set iSource = .ThisWorkbook.ActiveSheet.Range(rRng)
        .Workbooks.Add (xlWBATWorksheet)
        iSource.Copy .ActiveWorkbook.Worksheets(1).Range("A1")
        Set iSource = Nothing
        .ActiveWorkbook.SaveAs iFileName, xlText ', Local:=True
        .ActiveWorkbook.Close False
        .DisplayAlerts = True: .ScreenUpdating = True
    End With
End Sub
Быстрое удаление значений ячеек по условию
 
Цитата
НСС написал:
мгновенно
? "мгновенно" никогда не будет ...
Код
Private Sub CommandButton2_Click()
    Dim i&, t!, usl, tbl
    
    t = Timer
    
    usl = Range("J5").Value
    tbl = Range("A1:A10000").Value
    For i = 1 To 10000
        If tbl(i, 1) <= usl Then tbl(i, 1) = ""
    Next
    Range("A1:A10000").Value = tbl
    
    MsgBox CStr(Timer - t)
End Sub
Как извлечь данные из одной ячейки и вставить в разные столбцы?
 
Цитата
efendi написал:
извлечь данные до слэша, после слэша, и данные между скобками
С этим (с формулами) всегда будут проблемы, значит "изделия ручной работы":

1. "9/11 / 9/11 (2017) WEB-DL 1080p | iTunes скачать торрент фильм бесплатно без регистрации в хорошем качестве"
1. "9/11 / 9/11 (2017) WEB-DLRip | iTunes скачать торрент фильм бесплатно без регистрации в хорошем качестве"
1. "90 минут / 90 minutter / 90 Minutes (2012) HDRip | L1 скачать торрент фильм бесплатно без регистрации в хорошем качестве"
2. "9 Рота скачать торрент фильм бесплатно без регистрации в хорошем качестве"

1. который слэш ?
2. "словарь исключённых слов", однако, нужен

Может макрос ?
:)  
Как извлечь данные из одной ячейки и вставить в разные столбцы?
 
Цитата
efendi написал:
8 строк вручную - для примера

Если произойдёт что-то такое:

1+1: Голливудская история скачать торрент фильм бесплатно без регистрации в хорошем качестве

тогда и "Святой Боже не поможе(т)", будут "изделия ручной работы" или разработка словаря исключённых слов.

VBA. При вставке данных из буфера обмена вставляются 2 квадрата
 
Цитата
sokol92 написал:
мы на форуме обсуждали эту тему
Вы (специалисты) конечно да, но elena_VVV нет, как видно, иначе не было бы темы, это было "адресовано" ей.
Вам я бы не стал писать очевидные вещи - спасибо за ссылки буду читать темы.
VBA. При вставке данных из буфера обмена вставляются 2 квадрата
 
Цитата
elena_VVV написал:
проблема, которая возникает только  у пользователей с Windows 10

Цитата
Юрий М написал:
Windows 10 - проблема не воспроизводится

Это может так быть.
Проблемы стали появляться после выхода одного (какого ??? ... : ( ...  ) из обновлений Win8 и продолжаются до сих пор (Win10).
Проблемы с доступом к буферу обмена обнаруживаются только на некоторых компьютерах.

Например в гугле:

"problem with vba with clipboard win 10"
"Clipboard copy VBA code not working in Windows 10"

https://social.msdn.microsoft.com/Forums/en-US/3e52d53f-2c33-425f-a561-41b3c184006c/msforms-dataobje...
https://stackoverflow.com/questions/35416662/text-to-clipboard-in-vba-windows-10-issue
https://chandoo.org/forum/threads/clipboard-copy-vba-code-not-working-in-windows-10.37126/
https://www.mrexcel.com/forum/excel-questions/1066023-copy-clipboard-vba-problems.html

и т.д.

Вам может понадобиться использовать API:

https://docs.microsoft.com/en-us/office/vba/access/Concepts/Windows-API/send-information-to-the-clip...
https://docs.microsoft.com/en-us/office/vba/access/concepts/windows-api/retrieve-information-from-th...

Изменено: ocet p - 24 Авг 2019 12:40:56
Динамическая таблица со смещением итогов, Как автоматически расширить накладную при необходимости в конце иметь подведение итогов
 
Цитата
PooHkrd написал:
А в чем проблема?
Ну, никакая ... любопытство
Цитата
Voin написал:
Девочки просят, что б при заполнении последней строчки
Счастливец, меня всегда просят денег ... : )

Так может самый простой макрос из рекордера Excel, слегка исправленный вручную ? Справитесь ли вы с этим ?
При импорте файла CSV в Excel некорректно отображаются данные
 
Вы можете также использовать макрос или например вручную в Word (самый простой и "быстрый" способ).
При импорте файла CSV в Excel некорректно отображаются данные
 
Именно по этой причине - смотрите картинку.
Во многих местах последняя строка CSV-файла содержит символы возврата каретки (Carriage return character = vbcr = character 13).
Надо почистить такой файл от ненужных символов № 13 ... вот какое невезение, ну и "счастливо" в пятницу ... : )
Динамическая таблица со смещением итогов, Как автоматически расширить накладную при необходимости в конце иметь подведение итогов
 
Это всегда будет ячейка на 3 строки выше и в том же столбце, значит "R[-3]C" (3 линии от "Всего наименований:"), посмотрите на запись № 5 Игоря Гончаренко (то же правило, что и для суммы в столбце "E"). Функция не нужна, просто ссылка на ячейку - конечно используя схему RC.

пс:
Почему в функции "VLOOKUP(Bx:By;Модель!E2:F1001;2;0)" вы ввели диапазон в качестве аргумента номер 1, а не ссылку на ячейку ?
VBA. Вставка имени "умной таблицы" в код макроса
 
Цитата
Александр Иванов написал:
не работает
А этот код работает у вас или нет ?
Код
Option Explicit

Sub abc_xyz()
    Dim i, col, rws, t!
    With Sheets("data")
        .Select
        With .ListObjects("Таблица1")
            .HeaderRowRange.Select:                     t = Timer: While Timer - t < 0.8: DoEvents: Wend
            .DataBodyRange.Select:                      t = Timer: While Timer - t < 0.8: DoEvents: Wend
            'Столбце
            col = .HeaderRowRange.Count
            For i = 1 To col
                '.ListColumns(i).Range.Cells(1).Select:  t = Timer: While Timer - t < 0.4: DoEvents: Wend
                'ili
                .HeaderRowRange.Cells(i).Select:        t = Timer: While Timer - t < 0.4: DoEvents: Wend
                .ListColumns(i).DataBodyRange.Select:   t = Timer: While Timer - t < 0.4: DoEvents: Wend
            Next
            'Строки
            rws = .ListRows.Count
            For i = 1 To rws
                .ListRows(i).Range.Cells(1).Select:     t = Timer: While Timer - t < 0.4: DoEvents: Wend
                '.ListRows(i).Range.Rows(1).Select:      t = Timer: While Timer - t < 0.4: DoEvents: Wend
                'ili
                .ListRows(i).Range.Select:              t = Timer: While Timer - t < 0.4: DoEvents: Wend
            Next
        End With
        .Range("A1").Select
    End With
End Sub
Если это так, проверьте (через "F8") шаг за шагом, как вы можете добраться/получить к именам заголовков столбцов и строк, и так далее.
Динамическая таблица со смещением итогов, Как автоматически расширить накладную при необходимости в конце иметь подведение итогов
 
Цитата
Voin написал:
что это даст?
Для чего вам нужна функция "MAX(A4:A25)", если в ячейке "A25" имеется максимальное значение (это также общее количество строк в таблице), которое может иметь место в диапазоне "A4:A25" (сортировка по возрастанию значений) ?

п.с.: может макрос ?
:)  
Динамическая таблица со смещением итогов, Как автоматически расширить накладную при необходимости в конце иметь подведение итогов
 
MAX(A4:A25) = A25
Перенос Формата ячеек на другой лист
 
Цитата
xxddsxx написал:
перенос форматирования (цвет ячейки, шрифт)
Может например так ?
Код
Option Explicit

Sub abc_xyz()
    Dim i As Long
    Dim ptrn As Object, cell As Object
    
    Set ptrn = Sheets("Rezerv").Range("A1:B22")
    
    For Each cell In Sheets("Rezerv").Range("D1:E22").Cells
        i = i + 1
        With ptrn.Cells(i)
            'cell.Value = .Value
            cell.Interior.Color = .Interior.Color
            cell.Font.Name = .Font.Name
            cell.Font.Size = .Font.Size
            cell.Font.FontStyle = .Font.FontStyle
            cell.Font.Color = .Font.Color
            cell.HorizontalAlignment = .HorizontalAlignment
            cell.VerticalAlignment = .VerticalAlignment
            'i t.d.
        End With
    Next
    
    Set ptrn = Nothing
End Sub
[ Закрыто] Проблема с вложенным условием vba, Не выполняется второе условие
 
?
Пожалуйста и вы помогите помогающим тоже, и начните с начала и с примером, а не изнутри и без примера
Перенос данных между двумя "умными" таблицами в VBA
 
Цитата
buchlotnik написал:
предупреждать надо
:)  Ну и вы не предупредили, что улучшите свой код ... написал бы по другому  :)  
Перенос данных между двумя "умными" таблицами в VBA
 
Цитата
telephone122 написал:
чуть-чуьт по подробнее
Например, три варианта на выбор:
Код
Option Explicit

Sub abc_xyz()
    Dim rws&, tbl
    Dim dtbdrng As Object
    
    With Sheets("Export")
        On Error Resume Next
            Set dtbdrng = .ListObjects.Item("Table3").DataBodyRange
        On Error GoTo 0
        If dtbdrng Is Nothing Then MsgBox "Net dannykh": Exit Sub
        tbl = dtbdrng.Value
        Set dtbdrng = Nothing
    End With
    
    'Variant I s "DataBodyRange" i "ListRows"
    With Sheets("Import")
        With .ListObjects.Item("Table4")
            On Error Resume Next
                Set dtbdrng = .DataBodyRange
            On Error GoTo 0
            If dtbdrng Is Nothing Then rws = 2 Else rws = .ListRows.Count + 2
            .Range.Cells(rws, 1).Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
            tbl = Empty
            Set dtbdrng = Nothing
        End With
    End With
    
    'Variant II tol'ko s "ListRows"
    With Sheets("Import")
        With .ListObjects.Item("Table4")
            rws = .ListRows.Count + 2
            .Range.Cells(rws, 1).Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
            tbl = Empty
        End With
    End With
    
    'Variant III - kod kollegi "buchlotnik"
    With Sheets("Import")
        With .ListObjects.Item("Table4")
            rws = .ListRows.Count
            If rws = 0 Then
                Sheets("Export").Range("Table3").Copy .Parent.Range("Table4[q]")
            Else
                .Range.Cells(rws + 2, 1).Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
            End If
            tbl = Empty
        End With
    End With
End Sub

Пожалуйста, прочитайте тоже об этом:

ListObjects (или ListObjects.Item)
ListObjects(1).Resize (или ListObjects.Item(1).Resize)
DataBodyRange
ListColumns
ListColumns(x).TotalsCalculation
ListRows
ListRows.Add
TotalsRowRange
HeaderRowRange
Перенос данных между двумя "умными" таблицами в VBA
 
Цитата
telephone122 написал:
Макрос начинает вставлять данные не с о второй строки, а с третьей
Как коллега buchlotnik выше или вы должны проверить «DataBodyRange» и рассчитать «ListRows» на этой основе.
Закончить автоматический пересчет формул и последующее выполнение кода макроса
 
Цитата
pinguindell написал:
код, который прописывает в таблице формулы
По моему вы должны изменить формулы на "чистый код" vba
Что делает этот монстр ?
Код
ActiveSheet.Range(Cells(2, 23), Cells(clearLastRow_overdue, 23)).FormulaR1C1 = _
"=IF(AND(""Q1 Ia?""=[@[Date.Q]],COUNTIFS(R1C10:RC[-13],RC[-13])=1),MAXIFS ... ? :-( ? ... _
,RC[-13])=1),MAXIFS([Date.D],[Date.M-Y],[@[Date.M-Y]]),""""))))))))))))" & ""
Изменено: ocet p - 16 Авг 2019 17:57:01
Страницы: 1 2 3 4 5 6 7 8 9 10 11 След.
Наверх