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

Страницы: 1 2 3 4 След.
Ошибка run-time error при использовании метода open объекта recordset, появилась ошибка run-time error '-2147217865(80040e37)' после перехода на excel 2016
 
Надежда, у Вас база данных - это книга эксель, как в примере, или другая?
Сортировка сгруппированных строк
 
Посмотрите файл.
Запускайте макрос "СортировкаПоДвумСтолбцам".
Изменено: artemkau88 - 06.05.2021 22:32:47
Ошибка run-time error при использовании метода open объекта recordset, появилась ошибка run-time error '-2147217865(80040e37)' после перехода на excel 2016
 
Проверяйте
Ошибка run-time error при использовании метода open объекта recordset, появилась ошибка run-time error '-2147217865(80040e37)' после перехода на excel 2016
 
У вас не полный пример, поля, которые выбираются SQl запросом, отсутствуют. Можете приложить более полный пример?
можно ли двумерный массив записать в строку?
 
Большое спасибо! Разобрался!
Изменено: artemkau88 - 01.05.2021 21:51:52
можно ли двумерный массив записать в строку?
 
Подскажите, можно ли двумерный массив записать в строку при помощи resize?
Или только циклом, например так:
Код
    For i = LBound(Result, 1) To UBound(Result, 1)
        For k = LBound(Result, 2) To UBound(Result, 2)
            RowTarget = Result(i, k)
            Set RowTarget = RowTarget.Offset(0, 1)
        Next k
    Next i
Добавление элементов в динамический двумерный массив из драгого массива
 
Всем привет!

Никак не могу разобраться с двумерными массивами. Как заполнять двумерный массив с сохранением предыдущих элементов?
Есть код:
Код
Sub Пример()
Dim i, Counter, myArr
Dim Criterial, RowTarget As Range, Result
Criterial = Cells(7, 1)
Set RowTarget = Range("a10")
myArr = Range("h1:j5")
For i = LBound(myArr, 1) To UBound(myArr, 1)
    If myArr(i, 1) = Criterial Then
                Counter = Counter + 1
                If Counter = 1 Then
                    ReDim Result(0, 1)
                Else
                    ReDim Result(UBound(Result), UBound(Result) + 1)

                End If
                Result(UBound(Result), UBound(Result)) = myArr(i, 2)
                Result(UBound(Result), UBound(Result) + 1) = myArr(i, 3)
    End If
Next i
RowTarget.Resize(1, UBound(Result) + 1) = Result

End Sub
Запутался с redim preserve.

Пример во вложении.
Всем большое спасибо!
Извлечение более одной строки из одной таблицы в другую по нескольким критериям
 
Еще вариант для первого примера:
Код
Sub Сравнение()
Dim i, Counter, myArr
Dim TimeStart As Date, TimeEnd As Date
Dim Criterial, RowTarget As Range, Result()
TimeStart = Application.InputBox("Выберите начальную дату и время", , , , , , , 8)
TimeEnd = Application.InputBox("Выберите конечную дату и время", , , , , , , 8)

Criterial = Application.InputBox("Выберите критерий", , , , , , , 8)
myArr = Application.InputBox("Выберите диапазон для поиска", , , , , , , 8)
Set RowTarget = Application.InputBox("Выберите начальную ячейку для записи результата", , , , , , , 8)
For i = LBound(myArr, 1) To UBound(myArr, 1)
    If myArr(i, 1) = Criterial Then
            If myArr(i, 3) >= TimeStart And myArr(i, 3) <= TimeEnd Then
                Counter = Counter + 1
                If Counter = 1 Then
                    ReDim Result(0)
                Else
                    ReDim Preserve Result(UBound(Result) + 1)
                End If
                Result(UBound(Result)) = myArr(i, 3)
            End If
    End If
Next i
RowTarget.Resize(1, UBound(Result) + 1) = Result

End Sub
Изменено: artemkau88 - 30.04.2021 15:38:23
Макрос для выпадающего списка выдает ошибку
 
Прошу прощения, ошибся в предыдущем сообщении.
Проблема в куске кода:
Код
    With Range("B13:B18").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, _
        Formula1:=ValidFormula
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With  
Где переменная ValidFormula -  это формула в проверке данных

У вас она  "=Лист5!$B$2:$B$3127", поэтому что бы вы не записывали в проверку данных, при изменении листа она будет пересчитываться в соответствии с формулой в коде, а не в проверке данных.
У вас строки удаляются из столбца В и вставляются в столбец С, поэтому нужно пересчитывать ссылку на первую ячейку столбца В в проверке данных.

Подправил код:
Код
ValidFormula = "=OFFSET(Лист5!$B$2,0,0,COUNTIFS(Лист5!$B$2:$B$1048576,"">""""""))" 


посмотрите:
Изменено: artemkau88 - 29.04.2021 13:22:14
Макрос для выпадающего списка выдает ошибку
 
У вас в проверке данных формула:
Скрытый текст
Она подтягивается из макроса, записанного в событии первого листа.
И из-за этого считает пустые строки
Предлагаю в коде вашу формулу заменить на
Скрытый текст

У меня в столбец C на 5 листе со второй строки добавляет корректно.
У вас в третьем столбце добавлялись накладные в следующую за последней заполненную строку. Последняя заполненная строка в третьем столбце была "Итого".
Без нее все корректно работает.
Изменено: artemkau88 - 29.04.2021 13:19:54
Макрос для выпадающего списка выдает ошибку
 
Посмотрите, файл. Если не так, то опишите белее подробно задачу: что должно получиться и алгоритм.
Как сохранить jpg в новую папку в директорию файла?
 
Посмотрите макрос:
Код
Sub asdasd()
    Dim sName As String, nName As String, dName As String, wsTmpSh As Worksheet
    Dim PictDir As String
    nName = Range("L10").Value
    dName = Range("L11").Value    
    aName = Range("L12").Value
    Range("A1:C10").Select
    With Selection
        .CopyPicture
        Set wsTmpSh = ThisWorkbook.Sheets.Add
        
        
        PictDir = ActiveWorkbook.Path & "\" & Format(dName, "dd-mm")
        
        If Dir(PictDir, vbDirectory) = "" Then MkDir (PictDir)
        
        sName = PictDir & "\" & aName & "_" & Format(dName, "hh mm") & "_" & nName
        
        With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart
            .ChartArea.Border.LineStyle = 0
            .Parent.Select
            .Paste
            .Export Filename:=sName & ".jpg", FilterName:="JPG"
            .Parent.Delete
        End With
    End With
    wsTmpSh.Delete
End Sub

Изменено: artemkau88 - 17.04.2021 20:38:21
Вычислить разницу по номерам между двумя таблицами
 
Посмотрите пользовательскую функцию в столбце "C"

В столбце E отсортированный по возрастанию правый столбец с вашими данными.
Перенос данных из ячейки в строки и с копированием строк.
 
Еще вариант:

Код
Sub ПереносСтрок()Dim i, rngTarget As Range
Dim newString As String

Set rngTarget = Range("F11")
For i = Cells(2, 1).Row To Cells(2, 1).CurrentRegion.Rows.Count
    
    newString = Left(Cells(i, 3), 3)
    
    rngTarget = Cells(i, 1).Value
    rngTarget.Offset(0, 1) = Cells(i, 2).Value
    rngTarget.Offset(0, 2) = newString
    rngTarget.Offset(0, 3) = Cells(i, 4).Value
    
    Set rngTarget = rngTarget.Offset(1, 0)
    
    newString = Mid(Cells(i, 3), 6, 3)
    
    rngTarget = Cells(i, 1).Value
    rngTarget.Offset(0, 1) = Cells(i, 2).Value
    rngTarget.Offset(0, 2) = newString
    rngTarget.Offset(0, 3) = Cells(i, 4).Value
    
    Set rngTarget = rngTarget.Offset(1, 0)
    
    newString = Right(Cells(i, 3), 3)
    
    rngTarget = Cells(i, 1).Value
    rngTarget.Offset(0, 1) = Cells(i, 2).Value
    rngTarget.Offset(0, 2) = newString
    rngTarget.Offset(0, 3) = Cells(i, 4).Value
    
    Set rngTarget = rngTarget.Offset(1, 0)

Next i
Изменено: artemkau88 - 04.04.2021 14:53:19
Макрос для добавления/удаления количества позиций в одной колонке
 
Посмотрите файл, все ли верно?
Изменено: artemkau88 - 02.04.2021 20:04:56
Изменение формата определенных ячеек, в зависимости от знака в ячейке с формулой
 
Цитата
Filipp Kalugin написал:
А если сохранить не с поддержкой макросов а как двоичная книга там макросы тоже будут работать?  

Да.

Чтобы посмотреть номер столбца, можно воспользоваться Immediate window  в редакторе Visual basic. Отобразить его можно в редакторе view -> immediate window.
- для определения номера столбца:

Код
? Range("t1").column
- для определения строки:

Код
? Range("t1").row
Числовой результат, который отобразится строкой ниже в этом окне будет номером столбца или строки

В примере определяется номер столбца ячейки T1
Изменено: artemkau88 - 02.04.2021 09:59:25
Изменение формата определенных ячеек, в зависимости от знака в ячейке с формулой
 
У вас столбец не 19, а 20.

В коде сторку:
Код
If Target.Column <> 18 Then Exit Sub
замените на
Код
If Target.Column <> 20 Then Exit Sub

получится:

Код
Private Sub Worksheet_Change(ByVal Target As Range)
 
If Target.Column <> 20 Then Exit Sub
 
If InStr(Target.Formula, "+") Then
    Cells(Target.Row, 4).Interior.Color = vbYellow
    Cells(Target.Row, 4).Value = UCase("п")
    Cells(Target.Row, 4).Font.Bold = True
    Target.Interior.Color = vbYellow
 
ElseIf Target.HasFormula Then
    Cells(Target.Row, 4).Value = UCase("н")
    Cells(Target.Row, 4).Interior.Color = xlNone
    Cells(Target.Row, 4).Font.Bold = True
 
Else
    Target.Interior.Color = xlNone
    Cells(Target.Row, 4).Interior.Color = xlNone
    Cells(Target.Row, 4).Value = ""
End If
 
End Sub

Изменено: artemkau88 - 02.04.2021 09:39:56
Изменение формата определенных ячеек, в зависимости от знака в ячейке с формулой
 
Можете приложить пример файла, в котором не работает макрос?
Изменение формата определенных ячеек, в зависимости от знака в ячейке с формулой
 
Может структура таблицы другая? Вы вставляете в модуль листа?
Изменено: artemkau88 - 02.04.2021 09:14:20
Изменение формата определенных ячеек, в зависимости от знака в ячейке с формулой
 
Для работы в другой книге скопируйте макрос из сообщения 11 в модуль листа в книге, в которой вы хотите его применить.

Открываете книгу, в которую вы хотите скопировать макрос, нажимаете ALt+F11. Откроется редактор Visual Basic. Слева, в обзоре, щелкаете по нужному листу, и справа, вставляете макрос. Сохраняете книгу с поддержкой макросов и все.
Изменено: artemkau88 - 02.04.2021 09:12:41
Изменение формата определенных ячеек, в зависимости от знака в ячейке с формулой
 
Если ничего не меняем и столбцы те же, то:

Код
Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column <> 18 Then Exit Sub

If InStr(Target.Formula, "+") Then
    Cells(Target.Row, 4).Interior.Color = vbYellow
    Cells(Target.Row, 4).Value = UCase("п")
    Cells(Target.Row, 4).Font.Bold = True
    Target.Interior.Color = vbYellow

ElseIf Target.HasFormula Then
    Cells(Target.Row, 4).Value = UCase("н")
    Cells(Target.Row, 4).Interior.Color = xlNone
    Cells(Target.Row, 4).Font.Bold = True

Else
    Target.Interior.Color = xlNone
    Cells(Target.Row, 4).Interior.Color = xlNone
    Cells(Target.Row, 4).Value = ""
End If

End Sub
Изменено: artemkau88 - 01.04.2021 13:20:11
Изменение формата определенных ячеек, в зависимости от знака в ячейке с формулой
 
посмотрите код:

Код
Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column <> 18 Then Exit Sub
If InStr(Target.Formula, "+") Then
Cells(Target.Row, 4).Interior.Color = vbYellow
Cells(Target.Row, 4).Value = UCase("п")
Cells(Target.Row, 4).Font.Bold = True
Target.Interior.Color = vbYellow
Else
Target.Interior.Color = xlNone
Cells(Target.Row, 4).Interior.Color = xlNone
Cells(Target.Row, 4).Value = ""
End If
End Sub

Изменено: artemkau88 - 30.03.2021 13:10:46
Блокировка ячеек строки после заполнения
 
Посмотрите https://www.excel-vba.ru/chto-umeet-excel/kazhdomu-polzovatelyu-svoj-listdiapazon/.

Затем можно макросом сделать заливку заполненной строки. Строка заблокируется, но у пользователей все равно будет доступ по паролю. В модуль листа:

Код
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRange As Range
Dim myRow As Range
If Target.Column <> 10 Then Exit Sub

Set myRange = Range(Cells(Target.Row, 1), Cells(Target.Row, 9))
Set myRow = Range(Cells(Target.Row, 1), Cells(Target.Row, 10))
ActiveSheet.Unprotect
If Not IsEmpty(myRange) And Not IsEmpty(Target) Then
myRow.Interior.Color = RGB(245, 245, 220)
End If
Range(Cells(Target.Row, 1), Cells(Target.Row, 10)).Locked = True
ActiveSheet.Protect
End Sub
Изменено: artemkau88 - 30.03.2021 10:07:00
Преобразовать в дни нестандартную форму времени
 
Посмотрите файл с функцией в втором столбце. Единственное условие, чтобы месяцы записывались "мес" а не "м".

Эта формула не учитывает високосный год.
Изменено: artemkau88 - 29.03.2021 11:04:29
Контроль ввода ФИО
 
Вот код, который преобразовывает значение ячейки в соответствие с регистром после ввода

Подправил код, думаю, так правильнее.

В модуль листа:

Код
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i, myArr()
Dim CharVariable As Integer, SpaceVariable As Integer

If Target = "" Then Exit Sub

SpaceVariable = FindLettersAfterSpace(Target)
CharVariable = FindSpaces(Target)

If CharVariable > 1 Or CharVariable = 0 Or SpaceVariable <> 3 _
Or ПроверкаИнициаловНаНаличиеТочки(Target) = False Then
MsgBox "Вводите инициалы через точку!!!"
Target.ClearContents
Exit Sub
End If

ReDim myArr(1 To Len(Target))


For i = 1 To Len(Target)
myArr(i) = Mid(Target, i, 1)
Next

For i = LBound(myArr) To UBound(myArr)
    If i = 1 Then myArr(1) = UCase(myArr(1))
    If i = UBound(myArr) - 1 Then myArr(UBound(myArr)) = UCase(myArr(UBound(myArr)))
    If i = UBound(myArr) - 1 Then myArr(UBound(myArr) - 2) = UCase(myArr(UBound(myArr) - 2))
Next
Target = Join(myArr, "")
End Sub

В отдельный модуль функции:

Код
Function FindSpaces(CharVariable As Range) As Integer
Dim i, myCounter, myVar As String
myCounter = 0
myVar = RTrim(CStr(CharVariable))
For i = 1 To Len(myVar)
If Mid(myVar, i, 1) = " " Then myCounter = myCounter + 1
Next
FindSpaces = myCounter
End Function

Function FindLettersAfterSpace(myRange As Range) As Integer
Dim i, k, myVar As String, Letter As Integer
Letter = 0
myVar = RTrim(CStr(myRange))
For i = 1 To Len(myVar)
If Mid(myVar, i, 1) = " " Then
    For k = 1 To Len(Mid(myVar, InStr(1, myVar, " "), Len(myVar)))
    Letter = k - 1
    Next k
    Exit For
    End If
Next
FindLettersAfterSpace = Letter
End Function

Function ПроверкаИнициаловНаНаличиеТочки(myRange As Range) As Boolean
Dim i, Letter As Integer
Dim newString As String

newString = Mid(myRange, InStr(1, myRange, " "), Len(myRange))

If Mid(newString, 3, 1) <> "." Then
ПроверкаИнициаловНаНаличиеТочки = False
Else
ПроверкаИнициаловНаНаличиеТочки = True
End If
End Function
Изменено: artemkau88 - 01.04.2021 20:42:59
Создание папки с датой и сохранения Бэкап файла в ней
 
так?
Код
Sub filesave11()
Dim myDir As String
myDir = ThisWorkbook.Path & "\" & Format(Now, "dd.mm.yyyy")
If Dir(myDir, vbDirectory) = "" Then MkDir (myDir)
fname = myDir & "\" & "Улицы_" & Format(Now, "dd.mm.yyyy") & ".xlsx"

ActiveWorkbook.SaveAs fname, 51
End Sub
Изменено: artemkau88 - 27.03.2021 20:49:55
Условное форматирование на основе совпадения части текста в столбце
 
Проверьте, так?
Изменено: artemkau88 - 27.03.2021 20:14:54
Изменение формата определенных ячеек, в зависимости от знака в ячейке с формулой
 
В модуль листа:

Код
Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column <> 18 Then Exit Sub
If InStr(Target.Formula, "+") Then
Cells(Target.Row, 4).Interior.Color = vbYellow
Cells(Target.Row, 4).Value = UCase("п")
Cells(Target.Row, 4).Font.Bold = True
Target.Interior.Color = vbYellow
End If
End Sub

Проверяйте, так?
Изменено: artemkau88 - 27.03.2021 17:47:26
Условное форматирование на основе совпадения части текста в столбце
 
Прошу прощения, не понял))

Должны подкрашиваться найденные данные в столбце 1? А несоответствие не должно, верно?
Изменено: artemkau88 - 27.03.2021 17:07:40
Изменение формата определенных ячеек, в зависимости от знака в ячейке с формулой
 
Посмотрите файл
Страницы: 1 2 3 4 След.
Наверх