Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 171 След.
Генерация шифра (цифры и буквы)
 
Откройте архив. Запустите макрос.
Код
Sub GenerateNumberDialog()
    GenerateNumber InputBox("Введите количество", "Генерация номеров", 1)
End Sub

Sub GenerateNumber(NN As Long)
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim ii As Long
    Dim ss As String
    Dim cl As Range
    For Each cl In ActiveSheet.UsedRange.Cells
        ss = cl.Value
        If cl.Value Like "АБВГ.######.### ПС" Then
            ss = Mid(ss, 6, 6) & Mid(ss, 13, 3)
            ii = ss
            dic.Item(ii) = 0
        End If
    Next
    
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim jj As Long
    Do
        If jj >= NN Then Exit Do
        ii = ii + 1
        If ii = 1000000000 Then ii = 0
        If Not dic.Exists(ii) Then
            ss = "000000000" & ii
            ss = Right(ss, 9)
            ss = "АБВГ." & Left(ss, 6) & "." & Right(ss, 3) & " ПС"
            With ActiveSheet
                .Cells(.UsedRange.Row + .UsedRange.Rows.Count, 1).Value = ss
            End With
            dic.Item(ii) = 0
            jj = jj + 1
        End If
    Loop
    
    Application.Calculation = Application_Calculation
End Sub
Как ускорить макрос?, Сопоставление таблиц
 
Код
Sub Base_Grade_to_assay_RSA2()
    Dim dicX As Object
    Set dicX = GetDicX()
    If dicX.Count = 0 Then Exit Sub
    If Not dicX.Exists("NS") Then Exit Sub
    
    Dim arrASSAYColumns As Variant
    arrASSAYColumns = GetArrASSAYColumns(dicX)
    
    Dim xNS As Long
    xNS = WorksheetFunction.Match("NS", dicX.Keys(), 0)
    
    Dim dicY As Object
    Set dicY = GetDicY(arrASSAYColumns(xNS))
    
    Dim arrRSA As Variant
    arrRSA = Worksheets("RSA").ListObjects("йцу").Range
    xNS = WorksheetFunction.Match("NS", Worksheets("RSA").ListObjects("йцу").HeaderRowRange, 0)
    
    Dim hh As Long
    Dim ss As Variant
    Dim yRSA As Long
    Dim yASSAY As Long
    For yRSA = 2 To UBound(arrRSA)
        If dicY.Exists(arrRSA(yRSA, xNS)) Then
            yASSAY = dicY.Item(arrRSA(yRSA, xNS))
            
            For hh = LBound(arrASSAYColumns) To UBound(arrASSAYColumns)
                ss = arrASSAYColumns(hh)(yASSAY, 1)
                ss = Replace(ss, ">", "")
                ss = Replace(ss, " ", "")
                ss = Replace(ss, "-", "")
                ss = Replace(ss, ",", ".")
                If InStr(ss, "<") > 0 Then
                    ss = Replace(ss, "<", "")
                    On Error Resume Next
                    ss = ss / 2
                    On Error GoTo 0
                End If
                arrASSAYColumns(hh)(yASSAY, 1) = ss
            Next
        End If
    Next
    
    PrintArr arrASSAYColumns, dicX
    
End Sub

Private Sub PrintArr(arr As Variant, dicX As Object)
    Application.ScreenUpdating = False
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim hh As Long
    Dim xx As Variant
    For Each xx In dicX.Items
        hh = hh + 1
        Worksheets("ASSAY").ListObjects("Assay").Range.Columns(xx).Value = arr(hh)
    Next
    
    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
End Sub

Private Function GetDicY(arr As Variant) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim yy As Long
    For yy = 2 To UBound(arr, 1)
        dic.Item(arr(yy, 1)) = yy
    Next
    
    Set GetDicY = dic
End Function

Private Function GetArrASSAYColumns(dicX As Object) As Variant
    Dim arr As Variant
    ReDim arr(1 To dicX.Count)
    
    Dim ii As Long
    Dim xx As Variant
    For Each xx In dicX.Items
        ii = ii + 1
        arr(ii) = Worksheets("ASSAY").ListObjects("Assay").Range.Columns(xx)
    Next
    
    GetArrASSAYColumns = arr
End Function


Private Function GetDicX() As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim arr As Variant
    Dim xx As Long
    Dim ric As Object
    Set ric = CreateObject("Scripting.Dictionary")
    arr = Worksheets("RSA").ListObjects("йцу").HeaderRowRange
    For xx = 1 To UBound(arr, 2)
        ric.Item(arr(1, xx)) = 0
    Next
    
    arr = Worksheets("ASSAY").ListObjects("Assay").HeaderRowRange
    For xx = 1 To UBound(arr, 2)
        If ric.Exists(arr(1, xx)) Then dic.Item(arr(1, xx)) = xx
    Next
    
    Set GetDicX = dic
End Function
Преобразование вертикального цикла в горизонтальный
 
Код
Sub пробег1() 'добавить последнюю колонку
Dim i As Long
Dim m As Long
m = 2
For i = Sheets("BASE").[B1].Column To Sheets("BASE").[NC1].Column Step 1
'For m = 2 To 17157 Step 47
Sheets("DATES").Cells(m, 1).Value = Sheets("BASE").Cells(4, i).Value
    m = m + 47
    If m > 17157 Then Exit For
  'Next
  Next
End Sub
Перенос подзаголовков в отдельный столбец
 
Выделите диапазон, запустите макрос.
Код
Sub myTransfer()
    Dim yrr As Variant
    yrr = Selection.Value
    
    Dim urr As Variant
    ReDim urr(1 To UBound(yrr, 1), 1 To UBound(yrr, 2))
    
    Dim xx As Long
    Dim yy As Long
    Dim uu As Long
    Dim dt As Date
    
    For yy = 1 To UBound(yrr, 1)
        If Not IsEmpty(yrr(yy, 1)) Then
            If IsDate(yrr(yy, 1)) Then
                dt = DateValue(yrr(yy, 1))
            End If
        Else
            uu = uu + 1
            urr(uu, 1) = dt
            For xx = 2 To UBound(yrr, 2)
                urr(uu, xx) = yrr(yy, xx)
            Next
        End If
    Next
    
    With Workbooks.Add(1).Sheets(1).Cells(1, 1).Resize(UBound(urr, 1), UBound(urr, 2))
        .Value = urr
        .Columns(1).NumberFormat = "[$-419]mmmm yyyy;@"
        .Columns(1).AutoFit
    End With
End Sub
Работа с массивами данных, Фильтр и запись данных
 
Код
C2    =B2&","&ЕСЛИОШИБКА(ВПР(A2;A3:$C$1048576;3;0);"")
D2    =(СЧЁТЕСЛИМН($A$1:A2;A2)=1)+D1
E2    =ЕСЛИОШИБКА(ИНДЕКС(A:A;ПОИСКПОЗ(СТРОКА(E1);D:D;0));"")
F2    =ЕСЛИОШИБКА(ПСТР(ВПР(E2;A:C;3;0);1;ДЛСТР(ВПР(E2;A:C;3;0))-1);"")
и протянуть вниз.
Форма для заполнения таблицы, Разыскивается способ заполнения таблицы.
 
Код
Option Explicit

Private Sub Worksheet_selectionChange(ByVal Target As Range)
    If Target.Cells(1, 1).Value = "Отправить" Then
        myAdd Array(Now, Range("E5").Value, Get2(), Get3(1, 5), Get3(6, 10), Get3(11, 13))
    End If
End Sub

Function Get2() As String
    Dim ss As String
    Dim ob As OptionButton
    For Each ob In ActiveSheet.OptionButtons
        If ob.Value = 1 Then ss = ss & ob.Caption
    Next
    Get2 = ss
End Function

Function Get3(i1 As Long, i2 As Long) As String
    Dim ss As String
    Dim cb As CheckBox
    Dim ii As Long
    For ii = i1 To i2
        Set cb = ActiveSheet.CheckBoxes(ii)
        If cb.Value = 1 Then ss = ss & " " & ii & " " & cb.Caption
    Next
    Get3 = ss
End Function

Sub myAdd(arr As Variant)
    With Sheets("Данные")
        With .Cells(.Rows.Count, 1).End(xlUp).Cells(2, 1)
            With .Resize(1, UBound(arr) - LBound(arr) + 1)
                .Value = arr
            End With
        End With
    End With
    Application.StatusBar = arr(LBound(arr))
End Sub
Для этой задачи также подойдут пользовательские формы:
Работа с пользовательскими формами в VBA (baguzin.ru)
Изменено: МатросНаЗебре - 06.12.2022 15:40:53
Помогите с формулой для переноса непустых ячеек., Формулы не дают считать ячейки пустыми и переносить только непустые значения.
 
Без дубликатов. Формулы не массивные.
Код
D2:D11    =D1+(C2<>" ")*(СЧЁТЕСЛИМН($C$1:C2;C2)=1)
E2:E11    =ЕСЛИОШИБКА(ИНДЕКС($C$1:$C$11;ПОИСКПОЗ(СТРОКА(E1);D:D;0));"")
Помогите с формулой для переноса непустых ячеек., Формулы не дают считать ячейки пустыми и переносить только непустые значения.
 
Код
=ЕСЛИОШИБКА(ИНДЕКС($C$1:$C$11;1/(1/НАИБОЛЬШИЙ(($C$2:$C$11<>" ")*(СТРОКА($C$2:$C$11));СТРОКА(E1))));"")
Формула массива.
Изменено: МатросНаЗебре - 06.12.2022 15:13:53
Заполнение ячеек макросом
 
Цитата
написал:
осталось найти кто сможет сделать диалоговое окно
Нужна помощь с добавлением значений в столбце.
 
Worksheet_BeforeDoubleClick - По двойному клику будет добавлять в ячейку.
SelectionAdd - Выделить диапазон, запустить макрос.
Код
'В модуль листа
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    RangeAdd Target
End Sub

'В стандартный модуль
Sub SelectionAdd()
    Dim rr As Range
    On Error Resume Next
    Set rr = Intersect(Selection, ActiveSheet.UsedRange)
    On Error GoTo 0
    If rr Is Nothing Then Exit Sub
    
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim cl As Range
    For Each cl In rr.Cells
         RangeAdd cl
    Next
    
    Application.Calculation = Application_Calculation
End Sub
'В стандартный модуль
Sub RangeAdd(cl As Range)
    If Left(cl.Formula, 1) <> "=" Then
        If IsNumeric(cl.Formula) Then
            cl.Value = cl.Value + 1
        End If
    End If
End Sub
Необходимо написать формулу для расчета
 
Пишу в личку.
Сделал. Оплату получил.
Изменено: МатросНаЗебре - 06.12.2022 16:33:31
Автозаполнение повторяющихся позиций
 
Если формулами, то можно так. В ячейку H60:
Код
=ЕСЛИОШИБКА(ВПР(B60;$B$1:H59;7;0);"")
Переименовать файлы PDF
 
Пишу в личку.
Сделал. Оплату получил.
Изменено: МатросНаЗебре - 05.12.2022 11:31:26
Распределения списка на карточки, Список из 5000 английских слов с переводом надо превратить в карточки по 20 слов на каждой
 
Макросом так макросом.
Выделите диапазон, запустите макрос. При необходимости поменяйте количество строк nROWS.
Код
Sub SplitColumns()
    Const nROWS = 1700
    
    Dim rInp As Range
    On Error Resume Next
    Set rInp = Intersect(Selection, ActiveSheet.UsedRange)
    On Error GoTo 0
    If rInp Is Nothing Then Exit Sub
    
    Dim rOut As Range
    Set rOut = Workbooks.Add(1).Sheets(1).Cells(1, 1)
    
    Dim yy As Long
    For yy = 1 To rInp.Rows.Count Step nROWS
        rInp.Cells(yy, 1).Resize(nROWS, rInp.Columns.Count).Copy rOut
        Set rOut = rOut.Cells(1, rInp.Columns.Count + 2)
    Next
End Sub
Сравнение ячейки таблицы по столбцам и строкам, Сравнение ячейки таблицы по столбцам и строкам и выделение при несовпадении
 
В ячейку C5 вставить условное форматирование с формулой и протянуть вниз.
Код
=И(D5<>"--";D5<>D4)
В ячейку E5 вставить условное форматирование с формулой и протянуть вниз.
Код
=И(D5<>"--";D5<>D6)
Подсчет ячейки при выполнении одного любого из многих условий, Если хотя бы одно условие выполняется, ячейка в диапазоне должна быть посчитана (+1).
 
Сделайте таблицу соответствия:
"б/л"    1
1          1
2          1
...
Добавьте вспомогательную строку, в которой через ВПР из таблицы соответствия тяните числовые значения.
Сумму вычисляйте обычной СУММ() по вспомогательной строке.
Можно ли использовать пользовательскую функцию в формуле проверки данных
 
Цитата
написал:
Не нахожу в Excel ... для проверки вводимых данных..
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) = "A1" Then
        If MaskCompare(Target.Value, "##-##", 1) = False Then
            MsgBox "Введённое значение неверно.", vbCritical
        
            Application.EnableEvents = False
            Application.Undo
            Application.EnableEvents = True
        End If
    End If
End Sub
Заполнение ячеек макросом
 
Бэкенд, без фронтенда.
Код
Sub test()
    FillRight Range("P26"), 3
    FillLeft Range("P26"), 6
    FillDown Range("P26"), 12
    FillUp Range("P26"), 4
End Sub

Sub FillRight(rr As Range, nn As Long)
    Dim arr As Variant
    ReDim arr(1 To nn)
    Dim yy As Long
    For yy = 1 To nn
        arr(yy) = yy
    Next
    rr.Resize(1, UBound(arr)) = arr
End Sub
Sub FillLeft(rr As Range, nn As Long)
    Dim arr As Variant
    ReDim arr(1 To nn)
    Dim yy As Long
    For yy = 1 To nn
        arr(yy) = nn - yy + 1
    Next
    rr.Offset(0, -nn + 1).Resize(1, UBound(arr)) = arr
End Sub
Sub FillDown(rr As Range, nn As Long)
    Dim arr As Variant
    ReDim arr(1 To nn, 1 To 1)
    Dim yy As Long
    For yy = 1 To nn
        arr(yy, 1) = yy
    Next
    rr.Resize(UBound(arr, 1), 1) = arr
End Sub
Sub FillUp(rr As Range, nn As Long)
    Dim arr As Variant
    ReDim arr(1 To nn, 1 To 1)
    Dim yy As Long
    For yy = 1 To nn
        arr(yy, 1) = nn - yy + 1
    Next
    rr.Offset(-nn + 1, 0).Resize(UBound(arr, 1), 1) = arr
End Sub
Система счисления, Помогите, пожалуйста!
 
До кучи.
Пользовательская функция для перевода из различных систем счисления (planetaexcel.ru)
Резиновый выпадающий список с шагом
 
Вставьте в G3 и протяните вправо:
Код
=СМЕЩ($G$2;0;(СТОЛБЕЦ()-СТОЛБЕЦ($G$2))*2;1;1)
В формуле выпадающего списка сошлитесь на G3.
Вместо G3 можно использовать любой другой диапазон, включая на вспомогательном листе.
Подсчёт количества заполненых ячеек в определённом диапазоне в тысяче файлов Excel
 
Код
Dim fso As Object

Sub Посчитать_в_ТТН()
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim aFiles As Variant
    aFiles = ShowFileDialog()
    If IsEmpty(aFiles) Then Exit Sub
    
    Dim yReport As Long
    Dim aReport As Variant
    ReDim aReport(1 To UBound(aFiles), 1 To 3)
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim vFile As Variant
    For Each vFile In aFiles
        yReport = yReport + 1
        JobFile vFile, aReport, yReport
    Next
    If yReport > 0 Then
        With Workbooks.Add(1).Sheets(1).Cells(1, 1).Resize(UBound(aReport, 1), UBound(aReport, 2))
            .Value = aReport
        End With
    End If
    
    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
End Sub

Private Sub JobFile(ByVal sFull, aReport As Variant, yReport As Long)
    Application.StatusBar = Right(sFull, 255)
    Dim wb As Workbook
    On Error Resume Next
    Workbooks(fso.GetFileName(sFull)).Close False
    On Error GoTo 0
    Set wb = Workbooks.Open(sFull, False, True)
    
    aReport(yReport, 1) = WorksheetFunction.CountA(wb.Sheets(1).Range("A18:A25"))
    aReport(yReport, 2) = wb.Name
    aReport(yReport, 3) = sFull
    
    wb.Close False
    Application.StatusBar = False
End Sub

Function ShowFileDialog() As Variant
'    Dim rInitialFileName As Range
'    Set rInitialFileName = ThisWorkbook.Names("шаблон").RefersToRange
    
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Path & "\"
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
'                    rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function
сохранить лист как отдельный файл в книге со ссылкой в названии на содержимую информацию ячейки, сохранить лист как отдельный файл
 
В таком варианте будет оставаться открытым исходный файл.
Код
Sub SaveFile()
   'Объявление переменных
   Dim CellValue As String
   Dim Path As String
   Dim FinalFileName As String
  
  ActiveSheet.Copy
  
   'Временно отключаем показ вспомогательных сообщений
   Application.DisplayAlerts = False
  
   'Задаём каталог сохранения файла (в данном случае текущий каталог)
   Path = ThisWorkbook.Path & "\"
  
   'Получаем значение ячейки
   CellValue = Range("a7")
  
   'Формируем итоговый путь и название файла
   FinalFileName = Path & CellValue
     
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        sh.Delete
    Next
   
   'Сохраняем файл
   ActiveWorkbook.SaveAs Filename:=FinalFileName, _
                      FileFormat:=xlOpenXMLWorkbook
                      'FileFormat:=xlOpenXMLWorkbookMacroEnabled 'Для сохранения файла с макросом
  
   'Включаем вывод сообщений
   Application.DisplayAlerts = True
  
   'Сообщение с результатом выполнения процедуры
   MsgBox "Файл успешно сохранен с названием - " & CellValue, vbInformation, "Результат"
  
  End Sub
сохранить лист как отдельный файл в книге со ссылкой в названии на содержимую информацию ячейки, сохранить лист как отдельный файл
 
Цитата
написал:
чуть не так в данном случае кнопка удаляется в исходном файле , а нужно наоборот в полученном
Нет.
вычленение значения, формула?
 
Код
=ЕСЛИ(ЛЕВСИМВ(ПРАВСИМВ(A1;4);3)="/2/";A1;"")
сохранить лист как отдельный файл в книге со ссылкой в названии на содержимую информацию ячейки, сохранить лист как отдельный файл
 
С удалением кнопки.
Код
Sub SaveFile()
 
   'Объявление переменных
   Dim CellValue As String
   Dim Path As String
   Dim FinalFileName As String
 
   'Временно отключаем показ вспомогательных сообщений
   Application.DisplayAlerts = False
 
   'Задаём каталог сохранения файла (в данном случае текущий каталог)
   Path = ThisWorkbook.Path & "\"
 
   'Получаем значение ячейки
   CellValue = Range("a7")
 
   'Формируем итоговый путь и название файла
   FinalFileName = Path & CellValue
    
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        sh.Delete
    Next
    
   'Сохраняем файл
   ActiveWorkbook.SaveAs Filename:=FinalFileName, _
                      FileFormat:=xlOpenXMLWorkbook
                      'FileFormat:=xlOpenXMLWorkbookMacroEnabled 'Для сохранения файла с макросом
 
   'Включаем вывод сообщений
   Application.DisplayAlerts = True
 
   'Сообщение с результатом выполнения процедуры
   MsgBox "Файл успешно сохранен с названием - " & CellValue, vbInformation, "Результат"
 
  End Sub

Сбор данных из word в excel, Много таблиц word - в одну Excel
 
Соберёт, но без учёта
Цитата
написал:
но колонки в ворде кривые
Код
Option Explicit
Dim fso As Object
Dim appWord As Object
Dim rOut As Range
    
Sub GetFromWord()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim aFiles As Variant
    aFiles = ShowFileDialog()
    If IsEmpty(aFiles) Then Exit Sub
    
    Set rOut = Workbooks.Add(1).Sheets(1).Cells(1, 1)
    
    Set appWord = CreateObject("Word.Application")
    appWord.Visible = True
    
    Dim vFile As Variant
    For Each vFile In aFiles
        JobWordFile vFile
    Next
    
    appWord.Quit
    Set appWord = Nothing
End Sub

Private Sub JobWordFile(ByVal sFull As String)
    appWord.Documents.Open sFull
    appWord.Selection.WholeStory
    appWord.Selection.Copy
    
    rOut.Parent.Parent.Activate
    rOut.Parent.Activate
    rOut.Select
    With ActiveSheet
        .Paste
        Set rOut = .Cells(.UsedRange.Row + .UsedRange.Rows.Count, 1)
    End With
    
    appWord.ActiveWindow.Close
End Sub

Function ShowFileDialog() As Variant
'    Dim rInitialFileName As Range
'    Set rInitialFileName = ThisWorkbook.Names("шаблон").RefersToRange

    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.doc*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Path & "\" 'rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
'                    rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function
Средневзвешенное значение с уловиями на VBA
 
Код
Sub MuggsyBogues()
    Dim sh As Worksheet
    Set sh = ActiveSheet
    With sh
        Dim yy As Long
        yy = .Cells(.Rows.Count, 1).End(xlUp).Row
        If yy = 1 Then Exit Sub
        
        Dim outputRange As Range
        Dim drr As Variant
        Dim nrr As Variant
        Dim mrr As Variant
        Dim prr As Variant
        Dim res As Variant
        
        drr = .Cells(1, "A").Resize(yy)
        nrr = .Cells(1, "C").Resize(yy)
        mrr = .Cells(1, "G").Resize(yy)
        prr = .Cells(1, "H").Resize(yy)
        Set outputRange = .Cells(1, "J").Resize(yy)
        
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        For yy = 2 To UBound(drr, 1)
            dic.Item(nrr(yy, 1)) = dic.Item(nrr(yy, 1)) + 1
        Next
        
        Dim arr As Variant
        Dim irr As Variant
        Dim player As Variant
        Dim uu As Long
        For Each player In dic.Keys
            uu = dic.Item(player)
            ReDim arr(1 To uu, 1 To 3)
            dic.Item(player) = Array(0, arr)
        Next
        For yy = 2 To UBound(drr, 1)
            player = nrr(yy, 1)
            irr = dic.Item(player)
            uu = irr(0) + 1
            arr = irr(1)
            arr(uu, 1) = drr(yy, 1)
            arr(uu, 2) = mrr(yy, 1)
            arr(uu, 3) = prr(yy, 1)
            dic.Item(player) = Array(uu, arr)
        Next
        
        Dim sum1 As Double
        Dim sum2 As Double
        ReDim res(1 To UBound(drr, 1), 1 To 1)
        For yy = 2 To UBound(drr, 1)
            player = nrr(yy, 1)
            irr = dic.Item(player)(1)
            sum1 = 0
            sum2 = 0
            For uu = 1 To UBound(irr, 1)
                If irr(uu, 1) < drr(yy, 1) Then
                    sum1 = sum1 + irr(uu, 2) * irr(uu, 3)
                    sum2 = sum2 + irr(uu, 2)
                End If
            Next
            If sum2 <> 0 Then
                res(yy, 1) = sum1 / sum2
            End If
        Next
        
        outputRange = res
    End With
End Sub
Организация складского учета
 
Код
B18:B32    =ВПР(СТРОКА(1:1);W:Y;3;0)
U18:U82    =ЦЕЛОЕ((СТРОКА(1:1)-1)/СЧЁТЗ($C$4:$O$4))
V18:V82    =ОСТАТ(СТРОКА(1:1)-1;СЧЁТЗ($C$4:$O$4))
W18:W82    =W17+(СМЕЩ($B$4;2+U18;1+V18)>0)
X18:X82    =СМЕЩ($B$4;2+U18;-1)
Y18:Y82    =СМЕЩ($B$4;2+U18;0)&ЕСЛИ(X18>1;"_"&X18;"")&", р-р"&СМЕЩ($B$4;0;1+V18)8)
Нажать на кнопку во всплывающем окне другого приложения
 
С просторов:
Код
Replace
hwndButton = PostMessage(hwndButton, BM_CLICK, 0, 0)
with
Call SendMessage(hwndButton, WM_LBUTTONDOWN, 0&, ByVal 0&)
Call SendMessage(hwndButton, WM_LBUTTONUP, 0&, ByVal 0&)

If no-go also try replacing the 'Call SendMessage' with 'Call PostMessage' (no other changes needed). Btw, neither of those returns an HWND, so never use hwndButton = with them.

If you need the declares:
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Нажать на кнопку во всплывающем окне другого приложения
 
Если кнопка на форме является выбранной, то можно и lhWndP.
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 171 След.
Наверх