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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 След.
Использование Эксель как "базу данных"
 
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 - 9 янв 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 ноя 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 - 4 апр 2020 21:37:30
Автозаполнение нумерации до конца смежного столбца
 
Добрый день! Приложите файл, и нам понятнее будет
Изменено: Dmitriy XM - 4 апр 2020 19:37:38
Ошибка при копировании листа в новую книгу (Method or data member not found)
 
Добрый день!

Попробуйте так
Код
Sub SheetsNames()
Dim i As Integer, ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
    i = i + 1
    Range("A" & i) = ws.Name
Next ws
End Sub
Редактирование динамического диапазона с использованием ListBox, Извините не могу понять, готовый пример не смог найти
 
Добрый день!

Пример для столбца "Значение"
Группировка данных с набором условий. Подтянуть наименования файлов.
 
Добрый день!

Для вставки новых столбцов попробуйте макрос
Вставка формулы макросом в диапазон ячеек
 
Добрый день!

Попробуйте так
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("A1:A1000")) Is Nothing Then
With Target
    .EntireRow.Insert
    .Formula = "=B2+B3"
End With
End If
End Sub
Формирование сводной таблицы из XML
 
Изменил, чтобы в ячейках не повторялись даты
Формирование сводной таблицы из XML
 
В итоговом не хватает "Пропадание сети"

Вот такой вариант получился
Формирование сводной таблицы из XML
 
Цитата
katran написал:
еще не добавил
Добавляйте и выкладывайте конечный файл
Формирование сводной таблицы из XML
 
katran, добрый день!

В какие графы записываются другие виды аварий "Iнп > Iут", "Авария МТЗ", "Пропадание сети" и т.д.? В графу Imax?
Ошибка при обновлении текущего времени с использованием IF
 
Здравствуйте!
Изменено: Dmitriy XM - 2 янв 2020 07:19:22
Прерывание отображения работы макроса
 
Добрый день!

По второму вопросу: скорее всего это зависит от производительности Вашего компьютера, и попробовать избавиться от зависания можно командой Application.ScreenUpdating = False, либо уменьшить количество циклов For i = 1 To 200
На время выполнения одного макроса отключить второй
 
С новым годом!
Может такой вариант, чтобы и очищение ячеек происходило и время записывалось?
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Intersect(Target, Range("I7:I70,Q7:Q70,Y7:Y70,AG7:AG70,AO7:AO70,AW7:AW70,BE7:BE70,E7:E70,M7:M70,U7:U70,AC7:AC70,AK7:AK70,AS7:AS70,BA7:BA70")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Range("E7:G64, I7:J64, M7:O64, Q7:R64, U7:W64, Y7:Z64, AC7:AE64, AG7:AH64, AK7:AM64, AO7:AP64, AS7:AU64, AW7:AX64, BA7:BC64, BE7:BF64").Value = Empty
Range("D7:D64, H7:H64, L7:L64, P7:P64, T7:T64, X7:X64, AB7:AB64, AF7:AF64, AJ7:AJ64, AN7:AN64, AR7:AR64, AV7:AV64, AZ7:AZ64, BD7:BD64").Value = Empty
Range("D3:AZ4").Value = Empty
With Target.Offset(0, -1)
   .Value = Time
   .EntireColumn.AutoFit
End With
Application.EnableEvents = True
End Sub

Изменено: Dmitriy XM - 1 янв 2020 10:24:34
VBA Повторить каждую строку нужное кол-во раз
 
Добрый день!
Код
Sub Макрос1()
Dim rng As Range
Dim Chislo As Integer, x As Integer
Set rng = Selection
If rng <> "" Then
    Chislo = CLng(InputBox("Сколько повторений выделенной строки?", "Введите данные", 2))
    For x = 1 To Chislo
        rng.EntireRow.Copy
        rng.EntireRow.Insert Shift:=xlUp, CopyOrigin:=xlFormatFromLeftOrAbove
    Next x
End If
End Sub
Сортировка внутри таблицы без разбивки объединения
 
outsider_cmp, попробуйте такой вариант
Сортировка внутри таблицы без разбивки объединения
 
В Вашем рабочем файле иная структура таблицы?
Макрос, написанный в этом файле, должен подойти для любого количества человек и специальностей
Сортировка внутри таблицы без разбивки объединения
 
Добрый день!
Так?
Страницы: 1 2 3 4 5 6 7 8 9 10 11 След.
Наверх