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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 13 След.
Отображать в ячейках диапазона формулы
 
Добрый вечер,

Можете ли вы привести какой-либо пример данных с желаемым результатом ?
Разбитие текста в ячейке для заполнение текстбоксов
 
Например:
Код
Option Explicit

Private Sub UserForm_Initialize()
    Dim primer
    primer = "12,25" '<= eto est' eta vasha yacheyka naprimer => primer = Range("A1").Value
    
    With UserForm1
        'Variant 1
        .TextBox1.Text = Split(primer, ",", -1, 1)(0)
        .TextBox2.Text = Split(primer, ",", -1, 1)(1)
        
        'Variant 2
        .TextBox1.Text = Left(primer, InStr(1, primer, ",", 1) - 1)
        .TextBox2.Text = Right(primer, Len(primer) - InStr(1, primer, ",", 1))
        
        'Variant 3
        .TextBox1.Text = Val(primer)
        .TextBox2.Text = Mid(primer, InStr(1, primer, ",", 1) + 1, Len(primer) - InStr(1, primer, ",", 1))
        
        'Variant 4
        primer = Split(primer, ",", -1, 1)
        .TextBox1.Text = primer(0)
        .TextBox2.Text = primer(1)
        
        'itd.
    End With
End Sub
Перенос данных из объеденных ячеек одного документа в одну ячейку другого документа. VBA, Макрос VBA
 
Цитата
EleeSha написал:
великие умы
:)  ... гмм ... к счастью, у меня пока нет гидроцефалии ... но есть асцит ... от пива ...  :)

А что делать с остальными столбцами (Направление, 1,2,3,4,5 и т. д.) ?
Ну, и в "Графике" 3 строки для каждой линии данных а в "Табельном" только две, как вписать 3 строки в 2 ?


Пс:
Вам придется использовать свойства: MergeArea и MergeCells, а также конструкции типа "Range.Сells(x,y)" => MergeArea.Cells(1,2), и т. д.
Макрос копирования и вставки по условию.
 
? Это что-то подобное ?
Код
'модуль ThisWorkbook
Private Sub Workbook_Open()
    Sheets("Лист1").Select
    Range("A1").Select
End Sub

'модуль Лист1
Private Sub Worksheet_Activate()
    Sheets("Лист1").Select
    Range("A1").Select
End Sub

'модуль Лист1
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target.Cells(1), Range("H5:N5,H8:N8,H11:N11")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
        Range("P" & Target.Cells(1).Row).Value = Target.Cells(1).Value
        Select Case Target.Cells(1).Row
            Case 5: Call Зеленый1
            Case 8: Call Зеленый2
            Case 11: Call Зеленый3
            Case Else: Application.EnableEvents = True: Exit Sub
        End Select
        Range("A1").Select
    Application.EnableEvents = True
End Sub
Макрос как удалить папку по пути из ячейки
 

https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=124321&a...

Макрос: Sub repyHekaM()

Переменна: Adr = .Hyperlinks(1).Address

Потом только команда: Kill Adr ..... RmDir Adr


Изменено: ocet p - 13 Янв 2020 23:56:42 (исправление ошибок Kill => RmDir)
Гиперссылка со значением из текста поменять на название файла
 
Не лучше попробовать переделать/переработать эти предыдущие (первые) макросы ?
Зачем 'Select', 'ActiveCell', и т.д. ?
Например:
Код
Option Explicit

Sub MakeHyper()
    Dim i As Long, LastRow As Long, Adr As String, Strg
    Dim Bekslashina As Boolean, Dirovskiy As Boolean, Dotov As Boolean
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    For i = 1 To LastRow
        Adr = Application.Trim(Cells(i, "A").Value)
        If Adr <> "" Then
            Bekslashina = CBool(InStr(1, Adr, "\", 1))
            Dirovskiy = CBool(Len(Dir(Adr, vbNormal)))
            Dotov = Len(Adr) - InStrRev(Adr, ".", -1, 1) = 4 'Dlya tipa: *.xlsx, *.xlsm
            If Bekslashina And Dirovskiy And Dotov Then
                Strg = Split(Adr, "\"): Strg = Split(Strg(UBound(Strg)), ".")(0)
                Cells(i, "A").Hyperlinks.Add Anchor:=Cells(i, "A"), Address:=Adr, TextToDisplay:=Strg
            End If
        End If
    Next
End Sub

Sub repyHekaM()
    Dim i As Long, LastRow As Long, Adr As String
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    On Error Resume Next
    For i = LastRow To 1 Step -1
        With Cells(i, "A")
            If Application.Trim(.Value) <> "" Then
                Adr = .Hyperlinks(1).Address:
                If Err.Number = 0 Then .Hyperlinks(1).Delete: .Value = Adr Else Err.Clear
            End If
        End With
    Next
End Sub

Sub MakerepyH()
    Dim i As Long, LastRow As Long, Strg
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row: Strg = LastRow \ 2
    On Error Resume Next '???
    For i = Strg To 1 Step -1 ' ... :) ...
        With ThisWorkbook.ActiveSheet.Cells(i, "A")
            If Application.Trim(.Value) <> "" Then .Hyperlinks(1).Follow
        End With
    Next
    For i = Strg + 1 To LastRow ' ... :) ...
        With ThisWorkbook.ActiveSheet.Cells(i, "A")
            If Application.Trim(.Value) <> "" Then .Hyperlinks(1).Follow
        End With
    Next
'    For i = 1 To LastRow
'        With ThisWorkbook.ActiveSheet.Cells(i, "A")
'            If Application.Trim(.Value) <> "" Then .Hyperlinks(1).Follow
'        End With
'    Next
End Sub
Изменено: ocet p - 13 Янв 2020 00:56:28
Разделение ячейки по переносу строки VBA
 
Dim masiv() ==> Dim masiv

Например:
Код
Option Explicit

Sub Call_KS_line() '... :)
    Dim i%, mmnt
    With ActiveSheet
        mmnt = ChrW(1025) & Chr(10)
        For i = 1040 To 1103
            mmnt = mmnt & ChrW(i) & Chr(10)
        Next
        mmnt = mmnt & ChrW(1105)
        [A1].Value = mmnt
        With .Shapes.AddTextbox(msoTextOrientationHorizontal, 150, 50, 40, 40)
            .Name = "Cube_AzHuRwPozA_1"
            With .TextFrame.Characters
                .Font.Size = 30: .Font.Bold = True
                For i = 0 To UBound(Split([A1].Value, Chr(10), -1, 1))
                    .Text = KS_line([A1], i) '<<<================================== ... :)
                    mmnt = Timer: While Timer - mmnt < 0.3: DoEvents: Wend
                Next
                .Text = ""
            End With
        End With
        .Shapes("Cube_AzHuRwPozA_1").Delete
        [A1].Clear
    End With
End Sub

Function KS_line(n As Range, Optional i% = 0)
    Dim masiv
    masiv = Split(n.MergeArea.Cells(1, 1).Value, Chr(10), -1, 1)(i)
    'masiv = Split(n.Cells(1, 1).Value, Chr(10), -1, 1)(i)
    KS_line = masiv
End Function
Гиперссылка со значением из текста поменять на название файла
 
2 в Cells(Rows.Count, 2), Cells(i, 2), и т.д. измените на "A" или 1
Str As String (и другие Str) измените на Strg As String / Strg
For i = 2 измените на For i = 1
Изменено: ocet p - 9 Янв 2020 06:04:30
Фильтрация данных по условию в ячейке, vba, macro
 
Например:
Код
Option Explicit

Sub test1()
    Const crit = "x"
    
    With ThisWorkbook
        Dim prd: prd = .Sheets("List1").Range("B5").Value
        prd = Replace(Replace(prd, "P", "", 1, -1, 1), "0", "", 1, -1, 1) + 2
        .Sheets("List3").ListObjects("Table1").Range.AutoFilter Field:=prd, Criteria1:="=" & crit
    End With
End Sub
Автоматизация группировки строк, Нужна помощь в автоматизации группировки большого количества строк
 
Цитата
Politeperson написал:
но я потрачу на это кучу времени
:sceptic: ... И как это связано с саморазвитием и самообразованием ?

Пожалуйста, "Вариант 3":
Код
Option Explicit

Sub zyx_cba()
    With ThisWorkbook.Sheets("Лист1").Range("A1")
        .ClearOutline
        .Select
    End With
End Sub

Sub abc_xyz()
    Dim rn&, rk&, rws&
    rk = 0: rn = 0: rws = Cells(Rows.Count, "A").End(xlUp).Row
    Application.ScreenUpdating = False
    With ThisWorkbook.Sheets("Лист1").Columns("A")
        Do Until rk > rws
            rn = rk + 1
            rk = .Range("A" & rn).End(xlDown).Row + 1
            .Rows(rk & ":" & rn + 1).Rows.Group
            .Rows(rk & ":" & rn + 1).Hidden = True
        Loop
    End With
    Application.ScreenUpdating = True
End Sub
Интересно, будет ли это работать у вас (из-за кириллицы) или нет ?
Автоматизация группировки строк, Нужна помощь в автоматизации группировки большого количества строк
 
Всегда ли слово "Турецкий" будет маркером начала блока данных ?
не работает маркер автозаполнения, отмена в файле с поддержкой макросов, после создания макросов для мультисписка не работают маркер автозаполнения (протягивание текста) и отмена (ctrl+Z)
 
Зачем вообще нужен этот макрос, если он ни для чего  не используется ? Только потому, чтобы он был ? Какова его задача ?
Копирование данных с таблицы по условию с другой таблицы
 
:) ... каждому что нравится и к чему привык ...  :)  ... только чтобы был выбор
Копирование данных с таблицы по условию с другой таблицы
 
:)
Ну что ж, в 3:30 утра вопросов больше чем ответов.
Я так "много" думал об QT, что SQL "сбежал".
Так например Ваш SQL для Dodger-j:
Код
Option Explicit

Sub Ne_karusel()
    Application.ScreenUpdating = False
    With ThisWorkbook
        With .Sheets("Result")
            .Range("A1").CurrentRegion.ClearContents
            
            Dim strCon$: strCon = "ODBC;DSN=Excel Files;DBQ=" & .Parent.FullName & ";"
            Dim unvrsl: unvrsl = _
            "SELECT [Data$.Email], [Data$.Familiya], [Data$.Obrazovaniye], [Data$.Opyt raboty], [Data$.Nachalo], [Data$.Okonchaniye], [Data$.Stbl7], [Data$.Stbl8], [Data$.Id] " & _
            "FROM [Data$], [Zapros$] " & _
            "WHERE [Zapros$.Email] = [Data$.Email];"
            
            With .QueryTables.Add(Connection:=strCon, Destination:=.Range("A1"), Sql:=unvrsl)
                .FieldNames = True
                .PreserveFormatting = True
                .Refresh BackgroundQuery:=False
                .Delete
            End With
            
            'Yesli budut problemy c datoy - znachit yesli budut tekstovye dannye v stolbtsakh
            'With .Range("E2:F" & .Cells(.Rows.Count, "E").End(xlUp).Row)
            '    .NumberFormat = "dd/mm/yyyy"
            '    unvrsl = .Value: .Value = unvrsl: unvrsl = Empty
            'End With
            
            .Range("A1").CurrentRegion.EntireColumn.AutoFit
        End With
    End With
    Application.ScreenUpdating = True
End Sub
Копирование данных с таблицы по условию с другой таблицы
 
Цитата
Dodger-j написал:
База данных 60 тыс строк
С таким количеством данных подумать бы уже о "ADO" или "QueryTables" ? Например:
Код
Option Explicit

Sub karusel()
    Dim r&
    Dim adrs$, dbPath$, strCon$, strSql$ ', dbDefaultDir$ '=> Variant 2
    Dim cel As Range
    Dim fldnms As Boolean: fldnms = True
    
    Application.ScreenUpdating = False
    With ThisWorkbook
        .Sheets("Result").Range("A1").CurrentRegion.ClearContents
        
        'dbDefaultDir = .Path '=> Variant 2
        dbPath = .FullName
        
        With .Sheets("Zapros")
            adrs = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Address
        End With
        
        For Each cel In .Sheets("Zapros").Range(adrs).Cells
            strSql = "SELECT * FROM [Data$] WHERE [Email] = '" & cel.Text & "';"
            
            ' ---- Variant 1 ----
            strCon = "ODBC;DSN=Excel Files;DBQ=" & dbPath & ";"
            ' ---- Variant 2 ----
            'strCon = "ODBC;DSN=Excel Files;DBQ=" & dbPath & ";" & _
            "DefaultDir=" & dbDefaultDir & ";DriverId=1046;MaxBufferSize=2048;PageTimeout=5;"
            '---------------------
            'Yesli budut problemy:
            '1. izmenite "Excel Files" v 'DSN' na imya, kotoroye u vas yest' v vashey sisteme
            ' =>    'DSN=Excel Files'    <=
            '2. prover'te nomer drayvera 'DriverId=1046', mozhet byt' naprimer 'DriverId=790'
            '---------------------
            With .Sheets("Result")
                With .QueryTables.Add(Connection:=strCon, Destination:=.Range("A1").Offset(r, 0), Sql:=strSql)
                    .AdjustColumnWidth = False
                    .FieldNames = fldnms
                    .PreserveFormatting = False
                    .RefreshStyle = xlInsertEntireRows
                    .Refresh BackgroundQuery:=False
                    .Delete
                End With
                r = .Cells(.Rows.Count, "A").End(xlUp).Row
                If r > 0 And fldnms Then fldnms = False
            End With
        Next
        .Sheets("Result").Range("A1").CurrentRegion.EntireColumn.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub
Только с вашей кириллицей "QT" не хотело мне работать - но возможно с вашими драйверами будет.
Замена спецсимволов макросом
 
Пожалуйста, объясните более подробно и приложите соответствующий пример.
Замена спецсимволов макросом
 
Наверняка макросом из соответствующей темы форума ... :) ... например:

https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=63817
https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=113272&...
Заполнение таблицы на листе данными из UserForm
 
Цитата
Бобровский написал:
Но ... блин ... :( ...  не заполняет в таблице на листе, у меня, первую строку после шапки
:) Зачем блин а не пельмени ? ... :) .... У нас на, тот пример, теперь пельмени и борщ ...  :)

Вы можете также сделать это таким образом:
Код
    Dim ksv&, i%, prov$
    
    With ThisWorkbook.Sheets("База")
        ksv = .ListObjects("Таблица1").ListRows.Count
        prov = Trim(Join(Application.Index(.Range("A5").Offset(ksv, 0).Resize(1, 3).Value, 0), ""))
    End With
    
    If prov = "" Then ksv = 5 + ksv - 1 Else ksv = 5 + ksv
    
    With ThisWorkbook.Sheets("База")
        For i = 2 To 13
            .Cells(ksv + 1, i).Value = ...
        Next
        For i = 15 To 17
            .Cells(ksv + 1, i).Value = ...
        Next
        .Range("R" & ksv + 1).Value = ...
    End With
    '...

... но я не проверял это "от начала до конца" ...
Заполнение таблицы на листе данными из UserForm
 
Цитата
Logistic написал:
код если применять не TextBox1.TextBox2 и тд.,а txt_Время, txt_ДатаОтгрузки, txt_Количество и т.д.?
Например:
Код
    Dim ctrl
    
    ctrl = Array("TextBox1", "TextBox4", "TextBox6", "TextBox8", "TextBox10", "TextBox11", "TextBox12", "TextBox15")
    
    For i = LBound(ctrl) To UBound(ctrl)
        MsgBox Me.Controls(ctrl(i)).Value
    Next


пс:
Бобровский имеет такие конструкции ( UserForm1.Controls("TextBox" & i) ) в коде, например, в ListBox1_DblClick
Изменено: ocet p - 26 Дек 2019 01:41:16
Заполнение таблицы на листе данными из UserForm
 
Ad1) Например:

Код
    Dim ksv&
    'ksv = Sheets("База").UsedRange.Rows.Count + 1
    With ThisWorkbook.Sheets("База")
        ksv = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    End With

Редакт.:


У вас есть "ListObject" на листе, я не заметил этого раньше:
Код
    With ThisWorkbook.Sheets("База")
        'ksv = .ListObjects("Таблица1").Range.Rows.Count + 4 '? надо проверить
        'ksv = .ListObjects("Таблица1").ListRows.Count + 5 '? надо проверить
        ksv = .ListObjects("Таблица1").DataBodyRange.Rows.Count + 5
    End With

Вместо:
Код
    Range("Baza!B" & ksv).Value = TextBox1.Value
    '...
    Range("Baza!R" & ksv).Value = ComboBox1.Value
можно:
Код
    Dim i As Integer
    With ThisWorkbook.Sheets("База")
        For i = 2 To 13
            .Cells(ksv, i).Value = Me.Controls("TextBox" & i - 1).Value
        Next
        For i = 15 To 17
            .Cells(ksv, i).Value = Me.Controls("TextBox" & i - 2).Value
        Next
        .Range("R" & ksv).Value = Me.ComboBox1.Value
    End With

Вместо:
Код
    TextBox1.Value = ""
    '...
    ComboBox1.Value = ""
можно:
Код
    For i = 1 To 15
        Me.Controls("TextBox" & i).Value = ""
    Next
    Me.ComboBox1.Value = ""

Будет немного короче в коде.
Изменено: ocet p - 25 Дек 2019 03:05:43
Слияние Word и Excel: при открытии шаблона в Word не терять путь к файлу Excel, путь может меняться
 
Пожалуйста, попробуйте этот путь:

1. Стандартный модуль 'Word'
Код
Option Explicit

Public Const fayl_eksel = "Fayl_eksel_nomer_1.xlsx" 'Naprimer
Public dostup_k_faylu_eksel As String
2. Модуль 'ThisDocument':
Код
Private Sub Document_Open()
    dostup_k_faylu_eksel = ThisDocument.Path & "\" & fayl_eksel
    MsgBox "Dostup k faylu eksel:" & vbCrLf & vbCrLf & dostup_k_faylu_eksel
    If Dir(dostup_k_faylu_eksel, vbNormal) = "" Then
        MsgBox "Dostup k faylu eksel ustanovlen," & vbCrLf & _
        "no v papke net etogo fayla:" & vbCrLf & vbCrLf & "'" & fayl_eksel & "'"
    End If
End Sub
Слияние Word и Excel: при открытии шаблона в Word не терять путь к файлу Excel, путь может меняться
 
Цитата
eugene0807 написал:

... не терять путь к файлу ...

при условии что ... все шаблоны и сам файл Эксель буду в одной папке всегда
Добрый и вам,
Вы действительно так с этим вопросом ? Спрашиваю потому что он уже и содержит в себе половину ответа:

ThisWorkbook.Path / ThisDocument.Path

зависит с какой стороны смотреть. Или вы имели в виду что то другое ?
Узнать ActiveControl.Name зная только имя UserForm, Получение имени активного контрола зная только имя UserForm
 
Цитата
Sergoff написал:
Получение имени активного контрола
:qstn:
Активным элементом формы всегда будет тот элемент, на который вы нажимаете или к которому вы идете с клавишей TAB
Разделить числа через указанный интервал на 5 групп и записать в отдельные ячейки через запятую
 
Цитата
ZeroZer написал:
Как сделать
Лучшим решением будет ваша собственная функция UDF.
В простейшем варианте с "негибким" определением групп.
Но покуда вы "на цензуре" у мод-а, видно что ответов не будет ...    ... так ... постарайтесь ...
Изменено: ocet p - 18 Дек 2019 16:45:47 (устаревшая запись)
Как определить последнюю ячейку на листе через VBA?
 
Цитата
aosunproject написал: Нужно что бы данные добавили следующие строки после первых
Вы привели "много" примеров, за исключением того, как выглядят исходные данные, то есть те, которые должны быть скопированы.

Цитата
вытягивало например столбец "С" и до последней включно заполненной ячейки(кроме пустых).
У вас есть "дыры" в данных ?
Выбор последней заполненной ячейки в диапазоне.
 
Цитата
Scyth написал:
Выбор последней заполненной ячейки в диапазоне

Цитата
Scyth написал:
код, который ищет последнюю заполненную ячейку в диапазоне

Цитата
Scyth написал:
По строкам. Сначала по нижней, а если она пуста то по верхней

Цитата
Scyth написал:
удалить другой кнопкой. Если во второй строке оценок нет. то будет удалятся последняя оценка в строке выше
??? :sceptic: ???

Что-то в этом роде ?
Код
Sub Plus_1()
    If Application.CountA(Range("C9:J10")) < Range("C9:J10").Cells.Count Then
        Range("C9:J10").Cells(Application.CountA(Range("C9:J10")) + 1).Value = "1"
    End If
End Sub

Sub Minus_1()
    If Application.CountA(Range("C9:J10")) = 0 Then Exit Sub
    Range("C9:J10").Cells(Application.CountA(Range("C9:J10"))).Value = ""
End Sub
Определить пересечение строки и столбца при нескольких условиях
 
Почему бы не создать индекс с "Серия тепловоза" и "Тип профиля", тогда только "Index" и "Match" ?
удаление ячеек в строке с определенным шагом
 
Цитата
Kirasa написал:
и заканчивается всё на ячейке  EG1
? Для второй строки тоже, не на "EF2" ?
Как определить последнюю ячейку на листе через VBA?
 
Цитата
aosunproject написал:
Следующий файл перезаписывает прежнее данные
Например:
Код
Sub record_1()
    '...
    With ThisWorkbook.Sheets(1)
        SrcWbkSht.Range("C7", SrcWbkSht.Range("C7").End(xlDown)).Copy _
            Destination:=.Range("F" & .Rows.Count).End(xlUp).Offset(1, 0)
                Application.CutCopyMode = False
        '...
    End With
    '...
End Sub
Оператор "Is" в VBA возвращает "False" для одинаковых диапазонов
 
Цитата
Дмитрий(The_Prist) Щербаков написал:
Как видно, переменные rc и rc2 созданы через Set к одному объекту. Но сравнение Is считает их разными
Это уже раньше было замечено в этой теме, и, видимо, для этого служит оператор "Is", чтобы различать происхождение объектов.
Код
Sub abc_xyz()
    Dim a1 As Object, a2 As Object
    
    Set a1 = Range("A1")
    Set a2 = a1
    
    MsgBox a1 Is a2
    
    'If object1 and object2 both refer to the same object, result is True
End Sub
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 13 След.
Наверх