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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 12 След.
Чем заменить еслимн?
 
Код
=ЕСЛИ(D2="+";5;ЕСЛИ(СУММ(СУММПРОИЗВ(--(A2:C2="не требуется")))>0;3;ЕСЛИ(A2<B2;4;ЕСЛИ(A2>B2;2;1))))
Изменено: Dmitriy XM - 02.03.2024 21:48:34
Макрос умной разбивки на строки
 
Код
Sub qqq()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Ëèñò1")
    Dim rData As Range
    Set rData = ws.ListObjects(1).DataBodyRange
    Dim dStart As Date, dStop As Date, x As Long, house As Long
    Dim dNew As Date, rw As Long: rw = 9
    Dim iInt As Integer, iMod As Integer, i As Integer
    With rData
        ws.Range("E" & rw).CurrentRegion.ClearContents
        For x = 1 To .Rows.Count
            dStart = .Cells(x, 2)
            dStop = .Cells(x, 3)
            house = DateDiff("h", dStart, dStop)
            If house > 24 Then
                iInt = house / 24
                iMod = house Mod 24
                dNew = dStart
                For i = 1 To IIf(iMod > 0, iInt + 1, iInt)
                    dNew = DateSerial(Year(dNew), Month(dNew), Day(dNew) + 1)
                    If dNew > dStop Then
                        dNew = DateSerial(Year(dStop), Month(dStop), Day(dStop))
                        ws.Range("B" & rw) = .Cells(x, 1)
                        ws.Range("C" & rw) = dNew
                        ws.Range("D" & rw) = dStop
                        ws.Range("C" & rw, ws.Range("D" & rw)).NumberFormat = "dd.mm.yyyy hh:mm"
                        ws.Range("E" & rw) = DateDiff("h", dNew, dStop)
                    Else
                        ws.Range("B" & rw) = .Cells(x, 1)
                        ws.Range("C" & rw) = dStart
                        ws.Range("D" & rw) = dNew
                        ws.Range("C" & rw, ws.Range("D" & rw)).NumberFormat = "dd.mm.yyyy hh:mm"
                        ws.Range("E" & rw) = DateDiff("h", dStart, dNew)
                        dStart = dNew
                    End If
                    rw = rw + 1
                Next i
            Else
                ws.Range("B" & rw) = .Cells(x, 1)
                ws.Range("C" & rw) = dStart
                ws.Range("D" & rw) = dStop
                ws.Range("C" & rw, ws.Range("D" & rw)).NumberFormat = "dd.mm.yyyy hh:mm"
                ws.Range("E" & rw) = house
                rw = rw + 1
            End If
        Next x
    End With
End Sub
VBA. Аналог формулы ВПР(Excel) для работы с большими массивами., Способы реализации сопоставления данных в 2-х массивах с большим количеством "строк" (данных в 1-ой размерности).
 
Добрый день!

Если в каждой таблице уникальные клиенты, попробуйте все-таки через библиотеку в таком варианте
Просуммировать числа столбца и вставить сумму в соседнем столбце
 
И вот с макросом
Работает
Просуммировать числа столбца и вставить сумму в соседнем столбце
 
И макрос
Результат на листе ТЕСТ
Создание группы столбцов с помощью макроса
 
Вот
Изменено: Dmitriy XM - 19.08.2023 12:31:19
Посчитать комиссию к выплате с суммы без НДС. Указать ставку и сумму НДС на комиссию. И итоговую сумму к получению.
 
Добрый день!

Не совсем понятно что от чего должно считаться
[ Закрыто] VBA, замена БУКВЫ
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If Target = "" Then Exit Sub
    If Intersect(Target, Range("C:C")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Dim iValue As String
    iValue = Target.Value
    Target = iValue & "."
    Application.EnableEvents = True
End Sub
Посчитать сумму в одной таблице, по id во второй отфильтрованной таблице
 
.
Изменено: Dmitriy XM - 24.04.2023 22:28:25
Макрос - удаление строки/группы строк и перенос на другой лист
 
Такой вариант
Код
Sub Delete_Merge_Cells()
    Dim target As Range
    Set target = ActiveCell
    If Intersect(target, Range("F:F")) Is Nothing Then Exit Sub
    Dim wsDelete As Worksheet, rng As Range
    Dim rw As Long
    Set wsDelete = ThisWorkbook.Worksheets("Êîðçèíà")
    If target.MergeCells Then
        Set rng = target.MergeArea
        With wsDelete
            rw = .Range("D" & .Rows.Count).End(xlUp).Row + 1
            rng.EntireRow.Copy .Range("A" & rw)
            rng.EntireRow.Delete
        End With
    End If
End Sub
Заполнение шаблона Word из таблицы Excel
 
Добрый день!

Создавайте закладки в документе Word и вставляйте нужный текст по этим закладкам
Автоматическое заполнение таблицы с разных листов., Заполнение общего листа с определёнными параметрами с сохранением условного форматирования.
 
Вариант на PQ
Изменено: Dmitriy XM - 16.04.2023 08:59:30
Внесение данных в ListBox не с текущего листа.
 
Добрый день!

в этом месте макрос берет данные с активного листа
Код
t = "A2:E" & LastRow
Измените на
Код
t = .range( "A2:E" & LastRow)
Код из одного листа должен попасть в другой
 
Код
=ИНДЕКС(код!$D$8:$D$13;ПОИСКПОЗ(Лист2!C7;код!$B$8:$B$13))
VBA, как открыть файл CSV в виде строк с разделителями, VBA, как открыть файл CSV в виде строк с разделителями
 
Добрый день!

Если данные из CSV файла требуется для дальнейшей обработки, то можно их загнать в массив
Код
Sub Reading_CSV()
    
    Dim FSO As Object, oFileText As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Set oFileText = FSO.OpenTextFile("C:\Users\Harun\Documents\CSV file\Book2.csv", ForReading)
arr = oFileText.ReadAll
oFileText.Close

End Sub
Изменено: Dmitriy XM - 19.03.2023 08:56:57
Подсчет цифр в ячейках
 
Доброго дня!

Решение UDF
Использование Эксель как "базу данных"
 
dr_Solo, Добрый день!

В таком случае, лучше заносить данные в строку на лист "БазаОтчет" после заполнения протокола, а поля для ввода очищать для занесения следующих данных. Так как структура протокола не одинакова, может имеет смыл создать 4 базы данных (своя для каждого протокола). В случае необходимости восстановления протокола, возможет будет обратный порядок заполнения - из БД в протокол.
Во вложении файл с макросом для примера работы из протокола в БД
Копирование CSV файлов в один файл EXCEL из определенной папки, Копирование CSV файлов в один файл EXCEL из определенной папки
 
Замените на:
Код
Sub GetFilesCSV()
Dim FSO As Object, objFolder As Object
Dim wbOpen As Workbook, objFile As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = FSO.GetFolder("ВОТ СЮДА ПОЛНЫЙ ПУТЬ К ПАПКЕ")
For Each objFile In objFolder.Files
    If UCase(objFile.Name) Like "*.CSV" Then
        Set wbOpen = Workbooks.Open(objFile.Path)
        Sheets().Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        wbOpen.Close False
    End If
Next objFile
Set FSO = Nothing
End Sub
Копирование CSV файлов в один файл EXCEL из определенной папки, Копирование CSV файлов в один файл EXCEL из определенной папки
 
Здравствуйте, попробуйте так:
Код
Sub GetFilesCSV()
Dim FSO As Object, objFolder As Object
Dim wbOpen As Workbook, objFile As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Выбрать папку"
    .ButtonName = "Выбрать папку"
    .Filters.Clear
    .InitialFileName = "C:\Temp\"
    .InitialView = msoFileDialogViewLargeIcons
    If .Show = 0 Then Exit Sub
    Set objFolder = FSO.GetFolder(.SelectedItems(1))
End With
For Each objFile In objFolder.Files
    If UCase(objFile.Name) Like "*.CSV" Then
        Set wbOpen = Workbooks.Open(objFile.Path)
        Sheets().Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        wbOpen.Close False
    End If
Next objFile
Set FSO = Nothing
End Sub

Изменено: Dmitriy XM - 09.01.2021 16:07:26
Разделение двух столбцов по фамилиям и транспонирование столбцов
 
И еще вариант:
Код
Sub qwert()
Dim arrMonth(), ws As Worksheet, lRow%
arrMonth = Array("январь", "февраль", "март", "апрель", "май", _
"июнь", "июль", "август", "сентябрь", "октябрь", "ноябрь", "декабрь")
Set ws = ThisWorkbook.ActiveSheet
With ws
    lRow = .Range("A" & .Rows.Count).End(xlUp).Row
    For x = 1 To lRow
        If Not IsNumeric(Application.Match(.Range("A" & x).Value, arrMonth, 0)) Then
            If x > 1 Then
                .Range("A" & rw, .Range("B" & x)).Copy
                .Range("D" & rw).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone, False, True
            End If
            rw = x
            col = 4
        End If
        If x = lRow Then
            .Range("A" & rw, .Range("B" & x)).Copy
            .Range("D" & rw).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone, False, True
        End If
    Next x
End With
End Sub

CopyFromRecordset ограничения
 
RAN, и правильно думаете)))
Должно - Provider=Microsoft.ACE.OLEDB.12.0;Data Source=c:\myFolder\myExcel2007file.xlsx;Extended Properties="Excel 12.0 Xml;HDR=YES";
Подсчет количества разных символов по позициям
 
Добрый день!

Вариант макросом
Выразить аргумент объекта Range c помощью другого Range, принимает ли объектRange не явно заданные аргументы
 
Здравствуйте!

Вы же в Range передаете переменную, поэтому уберите кавычки и замените "+" на "&"
Код
If Sheets(1).Range(str_Var & CStr(i)).Value = Sheets(2).Range(str_Var & CStr(x)).Value Then
Как сделать подсчет только закрашенных ячеек + их процент, файл и скриншот прилагаю
 
Кирилл, Здравствуйте! Может так
Формирование списка НГ подарков детям по Ответственному лицу
 
Nusi, добрый день!

И вот такой вариант решения, если на одного ответственного приходится несколько городов и адресов. С одним адресом тоже работает
Код
Sub Podarki_NG()
Dim wsShablon As Worksheet, wsAdd As Worksheet, wsSheet As Worksheet
Dim arrData()
Dim dicWs As Object, dicCity As Object, dicAddress As Object, dicKont As Object
Dim x As Integer, i As Integer, rw As Integer, nub As Integer
Set dicWs = CreateObject("Scripting.Dictionary")
Set dicCity = CreateObject("Scripting.Dictionary")
Set dicAddress = CreateObject("Scripting.Dictionary")
Set dicKont = CreateObject("Scripting.Dictionary")
Set wsShablon = ThisWorkbook.Worksheets("ШАБЛОН")
Set wsSheet = ThisWorkbook.Worksheets("Лист рассылки")
nub = 2
Application.ScreenUpdating = False
With wsSheet
    If .Range("A2") <> "" Then .Range("A2", .Range("E" & .Range("A2").End(xlDown).Row)).ClearContents
End With
If ThisWorkbook.Worksheets.Count > 4 Then
    Application.DisplayAlerts = False
    For x = ThisWorkbook.Worksheets.Count To 5 Step -1
        ThisWorkbook.Worksheets(x).Delete
    Next x
    Application.DisplayAlerts = True
End If
arrData = ThisWorkbook.Sheets("Общий список").Range("A1").CurrentRegion.Value
For x = 2 To UBound(arrData, 1)
    If Not dicWs.Exists(arrData(x, 10)) Then dicWs.Add arrData(x, 10), arrData(x, 10)
Next x
For x = 0 To dicWs.Count - 1
    For i = 2 To UBound(arrData, 1)
        If arrData(i, 10) = dicWs.Keys()(x) And Not dicCity.Exists(arrData(i, 8)) Then dicCity.Add arrData(i, 8), arrData(i, 8)
    Next i
    For i = 0 To dicCity.Count - 1
        For r = 2 To UBound(arrData, 1)
            If arrData(r, 10) = dicWs.Keys()(x) And arrData(r, 8) = dicCity.Keys()(i) Then
                If Not dicAddress.Exists(arrData(r, 9)) Then
                    dicAddress.Add arrData(r, 9), arrData(r, 9)
                    If Not dicKont.Exists(arrData(r, 11)) Then dicKont.Add arrData(r, 11), arrData(r, 11)
                End If
            End If
        Next r
        For r = 0 To dicAddress.Count - 1
            Set wsAdd = ThisWorkbook.Worksheets.Add(, ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            With wsAdd
                .Name = dicWs.Keys()(x) & "-" & nub - 1
                .Tab.Color = vbRed
                wsShablon.Cells.Copy .Range("A1")
                .Range("B4") = dicCity.Keys()(i)
                .Range("B5") = dicAddress.Keys()(r)
                .Range("B6") = dicWs.Keys()(x)
                .Range("B7") = dicKont.Keys()(r)
                rw = 10
                For s = 2 To UBound(arrData, 1)
                    If arrData(s, 8) = dicCity.Keys()(i) And arrData(s, 9) = dicAddress.Keys()(r) And arrData(s, 10) = dicWs.Keys()(x) Then
                        .Range("E" & rw) = arrData(s, 2)
                        .Range("F" & rw) = arrData(s, 7)
                        rw = rw + 1
                    End If
                Next s
                .Range("B" & rw, .Range("B" & rw).End(xlDown)).EntireRow.Delete
            End With
            With wsSheet
                .Range("A" & nub) = nub - 1
                .Range("B" & nub) = dicCity.Keys()(i)
                .Range("C" & nub) = dicAddress.Keys()(r)
                .Range("D" & nub) = wsAdd.Range("C" & rw + 1)
                .Range("E" & nub) = wsAdd.Name
                nub = nub + 1
            End With
        Next r
        dicAddress.RemoveAll
        dicKont.RemoveAll
    Next i
    dicCity.RemoveAll
Next x
Set dicWs = Nothing
Set dicCity = Nothing
Set dicAddress = Nothing
Set dicKont = Nothing
Application.ScreenUpdating = True
End Sub
Изменено: Dmitriy XM - 11.11.2020 12:38:38
Получить список папок в заданном каталоге, VBA
 
Добрый день!
Код
Sub www()
Dim FSO As Object, fFolders As Object, fFolder As Object
Dim sFolderName As String
Set FSO = CreateObject("Scripting.FileSystemObject")
sFolderName = "D:\Download"
Set fFolders = FSO.GetFolder(sFolderName)
For Each fFolder In fFolders.SubFolders
    x = x + 1
    Range("A" & x) = fFolder.Name
Next fFolder
End Sub
Макрос для расчета промежуточного итога по группе товаров
 
Здравствуйте!
Код
Sub qwe()
For x = 3 To Range("H" & Rows.Count).End(xlUp).Row
    If Range("G" & x) = "" Then
        Range("H" & x).ClearContents
        Range("I" & x).ClearContents
        For i = x + 1 To Range("H" & Rows.Count).End(xlUp).Row
            If Range("G" & i) = "" Then
                x = i - 1
                Exit For
            End If
            Range("H" & x) = Range("H" & x) + Range("H" & i)
            Range("I" & x) = Range("I" & x) + Range("I" & i)
        Next i
    End If
Next x
End Sub
АГРЕГАТ. Подсчет часов в табеле рабочего времени, вопрос именно по функции (не работает)
 
Добрый день!

Ранее столкнулся с такой же ситуацией, и понял, что АГРЕГАТ()  не работает с виртуальными массивами, которые создаются внутри этой формулы
Собрать данные из двух таблиц в третью при совпадении данных
 
Здравствуйте!

Попробуйте такое решение
Код
=ЕСЛИОШИБКА(ЕСЛИОШИБКА(ЕСЛИ(ВПР(B23;Лист1!$C$3:$D$19;2;0)="активен";"акт.гр1");ЕСЛИ(ВПР(B23;Лист1!$L$3:$M$19;2;0)="активен";"акт.гр2"));"")
Как открывать файлы поочередно по возрастанию имени?
 
Такой вариант с сортировкой на листе
Код
Sub qwer()
Dim FSO As Object, oFile As Object
Dim wbOpen As Workbook, arr(), x As Integer
Set FSO = CreateObject("Scripting.FileSystemObject")
ReDim arr(1 To FSO.GetFolder(ThisWorkbook.Path & "\").Files.Count, 1 To 2)
For Each oFile In FSO.GetFolder(ThisWorkbook.Path & "\").Files
    If oFile.Name <> ThisWorkbook.Name Then
        x = x + 1
        arr(x, 1) = oFile.Path
        arr(x, 2) = Split(Split(FSO.GetFileName(oFile), "-КБ")(0), "П-")(1)
    End If
Next oFile
With Range("A1").Resize(x, 2)
    .Value = arr
    Erase arr
    .Sort Range("B1"), xlAscending
    arr = .Value
    .ClearContents
End With
For x = 1 To UBound(arr, 1)
    Set wbOpen = Workbooks.Open(arr(x, 1))
    '...
    wbOpen.Close False
Next x
End Sub
Изменено: Dmitriy XM - 04.04.2020 21:37:30
Страницы: 1 2 3 4 5 6 7 8 9 10 11 12 След.
Наверх