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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 28 След.
Ряд последовательных чисел через тире и запятые
 
Вот здесь есть несколько функций
Если такая возможность краткого рассчета сумм
 
Попробуйте, например, для U4
=СУММПРОИЗВ(C1:J1;C4:J4;C9:J9)
Проверка произвольно именнованных TextBox на форме
 
Hypohelix, привет
как-то так наверное
Код
Private Sub CommandButton3_Click()
Dim ctl As Control
For Each ctl In Me.Controls
    If InStr(ctl.Name, "TextBox") Then
        If Len(ctl.Text) = 0 Then ctl.Value = 0
    End If
Next ctl
End 

Лучше изменить имена текстбоксов, например: Tbx1, Tbx2, и т.д.,- чтобы не перебирать все контролы, а только Tbx

Из нескольких TextBox в одну ячейку
 
Dotodot500, привет
попробуйте так
Код
Private Sub CommandButton1_Click()
Sheets("Лист1").Cells(Rows.Count, 1).End(xlUp)(2, 1).Resize(, 2).Value = _
Array(Date, Me.TextBox1.Value & "; " & Me.TextBox2.Value & "; " & Me.TextBox3.Value)
End Sub
количество ячеек с условием по дате в них
 
кол-во писем до   01.10.17
=СЧЁТЕСЛИ(C2:L2;"<"&A2)
кол-во писем с опозданием до 10 дней
=СЧЁТЕСЛИМН(C2:L2;">"&A2;C2:L2;"<"&A2+10)
кол-во писем с опозданием более 10 дней
=СЧЁТЕСЛИ(C2:L2;">="&A2+10)

не проверенный вариант
Формирование базы В ТАБЛИЦЕ
 
Здравствуйте!
Наверное, так
Код
Sub ertert()
Dim x, bz, y(), i&, j&, k&

x = Range("A2", Cells(Rows.Count, 1).End(xlUp)).Value
bz = Range("E2:F" & Cells(Rows.Count, 5).End(xlUp).Row).Value
ReDim y(1 To UBound(x) * UBound(bz), 1 To 3)

For i = 2 To UBound(bz)
    For j = 2 To UBound(x)
        k = k + 1
        y(k, 1) = x(j, 1)
        y(k, 2) = bz(i, 1)
        y(k, 3) = bz(i, 2)
    Next j
Next i

Range("H3").Resize(k, 3).Value = y()
End Sub
Условное форматировани: выделение значений при совпадении левых символов
 
 ппопробуйте вот так

=ЛЕВСИМВ($A1;2)="ЧП"
Объединение ячеек, если в соседних - дубликаты, Требуется объединить ячейки с текстом там, где в соседнем столбце идут дубликаты.
 
Алексей Иванов, здравствуйте
попробуйте так
Код
Sub ertert()
Dim x, i&, j&, s$
With Range("A1").CurrentRegion
    x = .Value
    For i = 1 To UBound(x)
        If x(i, 1) <> s Then
            s = x(i, 1)
            j = i
        Else
            x(j, 2) = x(j, 2) & ", " & x(i, 2)
            x(i, 1) = "": x(i, 2) = ""
        End If
    Next i
    .Value = x
End With
End Sub
Добавление значений столбца на основе данных
 
Упс, не увидел сразу
попробуйте вот так
Код
Sub ertert()
Dim x, s$, i&, k&
With Range("A1", Cells(Rows.Count, 1).End(xlUp))
    x = .Value
    For i = 1 To UBound(x)
        If Len(x(i, 1)) Then
            s = x(i, 1): k = 0
        Else
            k = k + 1
            x(i, 1) = s & "-" & k
        End If
    Next i
    .Value = x
End With
End Sub
Добавление значений столбца на основе данных
 
Попробуйте так:
Выделить столбец А, нажать F5 - Выделить - Пустые ячейки - Ок
Затем нажать Ctrl и клавишу "-" (минус) - ячейки со сдвигом вверх - ок
Удаление дубликатов слов из ячейки, пример ячейки "self portrait self portrait" -> "self portrait"
 
Вот здесь UDF, вроде подходит для Вашей задачи
Перенос строк с листа на лист по условию
 
Очистка происходит вот здесь:
Код
With Range("A2").CurrentRegion.Resize(, 3).Offset(2)
    .ClearContents' очищаем диапазон перед вставкой данных
    If k > 0 Then .Resize(k).Value = y()
End With
Если данные расположены так, как в примере (первые 2 строки - заголовки, данные начинаются с 3-й строки), то должно работать.
Перенос строк с листа на лист по условию
 
Тогда диапазон нужно ограничить тремя столбцами
см. файл
Перенос строк с листа на лист по условию
 
Пожалста :)
Удаление листов по точному совпадению с названием с помощью макроса
 
Судя по примеру, вот так должно работать (в стандартный модуль):
Код
Sub ttt()
Dim wsh As Worksheet
With Application
    .DisplayAlerts = False
    For Each wsh In ThisWorkbook.Sheets
        If InStr(wsh.Name, "_") Or InStr(wsh.Name, "!") Then wsh.Delete
    Next wsh
    .DisplayAlerts = True
End With
End Sub
Удаление листов по точному совпадению с названием с помощью макроса
 
Здравствуйте. Можете привести примеры названий листов, и какие из них нужно удалить?
Перенос строк с листа на лист по условию
 
suigres, привет
попробуйте так (в модуль листа "report")
Код
Private Sub ComboBox1_Change()
Dim x, y(), i&, s$, k&
If Me.ComboBox1.ListIndex = -1 Then Exit Sub

x = Sheets("data").Range("A1").CurrentRegion.Value
ReDim y(1 To UBound(x), 1 To 3)
s = Me.ComboBox1.Value

For i = 2 To UBound(x)
    If x(i, 4) = s Then
        k = k + 1
        y(k, 1) = x(i, 1)    'HouseID
        y(k, 2) = x(i, 2)    'Адрес
        y(k, 3) = x(i, 3)    'Клиентов
    End If
Next i

With Range("A2").CurrentRegion.Offset(2)
    .ClearContents
    If k > 0 Then .Resize(k).Value = y()
End With
End Sub
Сделать слияние текста в отмеченных колонках
 
или UDF
Код
Function VidD(rOtm As Range, rVid As Range) As String
Dim x, y, j&, s$
x = rOtm.Value
y = rVid.Value
For j = 1 To UBound(x, 2)
    If Len(x(1, j)) Then s = s & ", " & y(1, j)
Next j
VidD = Mid(s, 3)
End Function
Транспорирование массива перед выгрузкой
 
Попробуйте вот эдак вот:
Код
Private Sub CommandButton1_Click()
Dim x, i&
x = Sheets("Расход").Range("A1:A10").Value    'данные в массив
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(x)
        .Item(x(i, 1)) = 1
    Next i
    '    в столбик
    [A1].Resize(.Count).Value = Application.Transpose(.keys)
    '    в строку
    [B1].Resize(, .Count).Value = .keys
End With
End Sub
Как выделить различающиеся ячейки в одной строке путем условного форматирования
 
Попробуйте вот такую формулу УФ
=$B2*14<>СУММ($B2:$O2)
Получить список уникальных значений по столбцам и строкам из таблицы
 
miadiva1, привет
попробуйте так
Код
Sub ertert()
Dim x, i&, v
x = Range("A1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        For Each v In Split(x(i, 1), ",")
            .Item(v) = Empty
        Next v
    Next i
    Range("A23").Resize(.Count).Value = Application.Transpose(.keys)
End With
End Sub
Копирование текста из ячейки после нажатия на неё
 
как-то вот так:
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("C2").CurrentRegion.Columns(3).Resize(, 3)) Is Nothing Then Exit Sub
With Sheets("Лист2")
    .Range("E3").Value = Cells(Target.Row, 3).Value
    .Range("I3").Value = Cells(2, Target.Column).Value
    .Activate
End With
End Sub
Копирование текста из ячейки после нажатия на неё
 
Вот так например:
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("C2").CurrentRegion.Columns(3).Resize(, 3)) Is Nothing Then Exit Sub
With Sheets("Лист2")
    .Cells(Rows.Count, 5).End(xlUp)(2, 1).Value = Cells(Target.Row, 3).Value
    .Cells(Rows.Count, 9).End(xlUp)(2, 1).Value = Cells(2, Target.Column).Value
End With
End Sub
Поиск строк содержащих конкретный набор символов из списка, Поиск строк содержащих конкретный набор символов из списка
 
например, вот
Код
Sub ertert()
Dim magz As Range, b As Range, poisk As Range, r As Range
Dim i As Long, l As Long
'Список самих магазинов, искомые значения:
Set magz = Range([a1], Cells(Rows.Count, 1).End(xlUp))
'Поисковый столбец, в котором ищем значения определенных магазинов:
Set poisk = Range([e1], Cells(Rows.Count, 5).End(xlUp))
poisk.Font.ColorIndex = xlAutomatic: magz.Font.ColorIndex = xlAutomatic

With CreateObject("VBScript.RegExp")
    .Global = True: .IgnoreCase = True
    For Each b In magz.Cells
        .Pattern = b.Value: l = 5
        For Each r In poisk.Cells
            If .Test(r) Then
                b.Font.Color = vbBlue
                With .Execute(r)
                    For i = 0 To .Count - 1
                        'совпадения выделяем красным
                        r.Characters(.Item(i).FirstIndex + 1, l + 1).Font.Color = vbRed
                    Next
                End With
            End If
        Next r
    Next b
End With
End Sub
VBA combo box с выпадающим меню из значений столбца.
 
Может вот это подойдет?
Изменено: nilem - 17.04.2017 06:31:17
Сравнение массива с коллекцией
 
еще цикл можно добавить:
Код
Sub ertert()
Dim a, x, i As Long, j As Long, temp$

a = Range("A7").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 2 To UBound(a)
        .Item(CStr(a(i, 3))) = 0    'По договору №
    Next i

    x = Sheets("Расход").Range("A1").CurrentRegion.Value
    For i = 2 To UBound(x)    'отбираем данные расхода
        If x(i, 7) <> "В" Then
            temp = Split(x(i, 2), "|")(1)    'договор
            If .exists(temp) Then .Item(temp) = .Item(temp) + x(i, 4)     'Кол-во расход
        End If
    Next i

    x = Sheets("Приход").Range("A1").CurrentRegion.Value
    For i = 2 To UBound(x)    'отбираем данные прихода
        temp = CStr(x(i, 2))
        If .exists(temp) Then
            .Item(temp) = .Item(temp) * x(i, 9)  'кол-во*цену
        End If
    Next i
    
    For i = 2 To UBound(a)
        If a(i, 4) <> .Item(CStr(a(i, 3))) Then MsgBox "Не сходится по дог. " & _
        a(i, 3) & ": " & a(i, 4) & " и " & .Item(CStr(a(i, 3))), 64
    Next i
    Range("G8").Resize(.Count).Value = Application.Transpose(.items)
End With
End Sub
Располагайте коды в стандартных модулях (не модулях листов)
Сравнение массива с коллекцией
 
OlegO, привет
а в чем вопрос-то?
Проверка словаря на наличие ключа, корректировка кода в цикле
 
Надо просто попробовать. Мне кажется, формулы будут быстро работать.
А если что, у Вас есть запасной вариант с макросом.
Проверка словаря на наличие ключа, корректировка кода в цикле
 
Формулка не слишком тяжелая, на несколько тыс строк, по идее, должна работать. Попробуйте, возможно подойдет.
По поводу "Оптимизация или нет". Нет, это другой код, хотя и похожий.
Проверка словаря на наличие ключа, корректировка кода в цикле
 
Вот с формулой
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 28 След.
Наверх