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

Страницы: 1 2 3 4 След.
Добавление строки по условию изменения ячейки в строке, Макросы VBA
 
наконец какой-то пример ... :)
попробуйте, это ваша расширенная версия:
Код
Option Explicit

Sub InsertRow_2()
    Dim r&: r = 2
    Dim rws&: rws = Range("a1").CurrentRegion.Rows.Count
    Dim col%: col = Range("a1").CurrentRegion.Columns.Count
    Dim zaglwk(): zaglwk = Range("a1").Resize(1, col).Value
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Do While r < rws
        If Cells(r, 1).Value <> "" Then
            If Cells(r + 1, 1).Value <> Cells(r, 1).Value Then
                Rows(r + 1).Insert Shift:=xlDown
                Cells(r + 1, 1).Resize(1, col).Value = zaglwk
                rws = rws + 1
                r = r + 1
            End If
        End If
        r = r + 1
    Loop
    Erase zaglwk
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
End Sub
Добавление строки по условию изменения ячейки в строке, Макросы VBA
 
этот "льупощак" (For...Each...Next) не подходящий
может так ?
Код
Option Explicit

Sub InsertRow_1()
    Dim r&: r = 1
    Dim rws&: rws = Selection.Rows.Count
    Do While r < rws
        If Trim(Cells(r, 1).Value) <> "" Then
            If Cells(r, 1).Offset(1, 0).Value <> Cells(r, 1).Offset(0, 0).Value Then
                Rows(1).Copy
                Cells(r, 1).Offset(1, 0).Insert
                Application.CutCopyMode = False
                Selection.Resize(rws + 1).Select 'это не обязательно
                rws = rws + 1
                r = r + 1
            End If
        End If
        r = r + 1
    Loop
End Sub
DblClick в ListBox вызывает выделение другого элемента списка
 
код похож на решение StoTisteg, но "dblclick" не хорош для этой цели
Код
Private Sub lbList_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Dim i As Long
    With lbList
        i = .ListIndex: If i = -1 Then Exit Sub
        If .ListCount = 0 Then Cancel = True
        'rRng(i + 1).EntireColumn.Hidden = Not rRng(i + 1).EntireColumn.Hidden
        If Not .Selected(i) = Columns(i + 1).Hidden Then Columns(i + 1).Hidden = .Selected(i)
    End With
    ActiveWindow.SmallScroll ToRight:=-(i + 1)
End Sub
Ошибка в макросе импорта в vcf файл
 
В вашем файле, листы, названные по-русски ("Лист1" ...), а в коде vba на английском языке ("Sheet1" ...) ... как это всё должно работать ?

пс: и ещё "крестик" в "FileNum" - "Open OutFilePath For Output As #FileNum" ... :)
Изменено: ocet p - 28 Ноя 2018 18:29:08
Поиск в тексте хХ (рядом строчная и заглавная) и вставка между ними символа
 
Цитата
lifesss написал:
сначала идет маленькая буква потом большая
Подготовьте себе словарь, содержащий слова с маленькими буквами или эти начинающиеся с прописных букв.
Потом просто, только поиск и замена ... или остается vba ... но без примера, неизвестно, что делать.
Объединить несколько столбцов с разделителем
 
Цитата
MaximPopov написал:
как сделать более простой вариант
Например, для вашего примера в "xlsx":
Код
Sub Makro2()
    With Range("A1").CurrentRegion
        .Range("D1").FormulaR1C1 = "=CONCATENATE(RC[-3],RC[-2],RC[-1])"
        .Range("D1", "D" & .Rows.Count).FillDown
    End With
    With Range("F1").CurrentRegion
        .Range("F1").FormulaR1C1 = "=CONCATENATE(RC[-5],RC[-4],RC[-3],RC[-2],RC[-1])"
        .Range("F1", "F" & .Rows.Count).FillDown
    End With
End Sub
, но это только суррогат.
Поскольку неизвестно, сколько будет этих "связанных" столбцов и как они будут "распространяться" в листе.
Назначение переменной в макрос - из текстового файла
 
Цитата
Dim Ozerov написал:
bedvit , файл не открыт
В окне "Immediate" введите и выполните команду "Close"

...

Исправьте переменную "s", например:
Код
    Const strPath$ = "C:\Temp\1.txt"
    Dim nmbr%, strfle$, s
    
    strfle = Dir(strPath, vbNormal)
    
    If strfle <> "" Then
        nmbr = FreeFile(0)
        Open strPath For Input Access Read Lock Read As #nmbr
        s = Input(LOF(nmbr), #nmbr)
        Close #nmbr
        
        s = Trim(s)
        Do While Right(s, 2) = vbCrLf
            s = Left(s, Len(s) - 2)
        Loop
        s = Trim(s)
        
        'i daleye
        ' ...
    End If
Изменено: ocet p - 21 Окт 2018 20:22:13
Макрос копирования ячеек при определенном значении в другом столбце
 
Например:
Код
Option Explicit

Sub sverkhu_vniz()
    Const chyo = 1 'usloviye
    Dim r&: r = 5 'nachalo
    Do Until Trim(Cells(r, "a").Value) = ""
        If Cells(r, "i").Value = chyo Then Cells(r, "g").Value = Cells(r, "f").Value
        r = r + 1
    Loop
End Sub
Вставка рисунка в ячейку с удалением предыдущего рисунка, с небольшим отступом от краев.
 
Например:
Код
Option Explicit

Const dostup$ = "C:\Temp\1.png" 'Vash dostup = papka i kartinka
Const strWhat = 2

Sub aaa()
Dim fnd, adrs$, dlin!, vys!, krtn

    With ActiveSheet.UsedRange
    
        For Each krtn In .Parent.Shapes
            Select Case krtn.Type
                Case msoLinkedPicture, msoPicture: If krtn.Name Like "Rys_*" Then krtn.Delete
                Case Else: 'Net
            End Select
        Next
        
        Set fnd = .Find(What:=strWhat, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
        If Not fnd Is Nothing Then
            adrs = fnd.Address(0, 0)
            Do
                dlin = (fnd.Offset(0, 1).Left - fnd.Left) - 2.5
                vys = fnd.EntireRow.RowHeight - 2.5
                Set krtn = .Parent.Shapes.AddPicture(dostup, msoFalse, msoTrue, fnd.Left + 1.5, fnd.Top + 1.5, dlin, vys)
                krtn.Name = "Rys" & "_" & fnd.Address(0, 0)
                krtn.Placement = xlMoveAndSize
                krtn.ControlFormat.PrintObject = True
                Set krtn = Nothing
                Set fnd = .FindNext(fnd)
            Loop While Not fnd Is Nothing And fnd.Address(0, 0) <> adrs
        End If
    End With
End Sub
Вставка рисунка в ячейку с удалением предыдущего рисунка, с небольшим отступом от краев.
 
Например:
Код
Option Explicit

Const dostup$ = "C:\Temp\1.png" 'Vash dostup = papka i kartinka
Const strWhat = 2

Sub aaa()
Dim fnd, adrs$, dlin!, vys!, krtn

    With ActiveSheet.UsedRange
        Set fnd = .Find(What:=strWhat, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
        If Not fnd Is Nothing Then
            adrs = fnd.Address(0, 0)
            Do
                dlin = (fnd.Offset(0, 1).Left - fnd.Left) - 2.5
                vys = fnd.EntireRow.RowHeight - 2.5
                Set krtn = .Parent.Shapes.AddPicture(dostup, msoFalse, msoTrue, fnd.Left + 1.5, fnd.Top + 1.5, dlin, vys)
                krtn.Name = "Rys" & "_" & fnd.Address(0, 0)
                krtn.Placement = xlMoveAndSize
                krtn.ControlFormat.PrintObject = True
                Set krtn = Nothing
                Set fnd = .FindNext(fnd)
            Loop While Not fnd Is Nothing And fnd.Address(0, 0) <> adrs
        End If
    End With
End Sub
Поиск дубликатов и пустых ячеек в произвольном столбце средствами VBA, Поиск и выделением их цветом. дубликатов и пустых ячеек в произвольном столбце средствами VBA
 
Цитата
Джек Восмеркин написал:
Макрос из макрорекордера дубликаты подсвечивает, но на пустые ячейки не реагирует
Например:
Код
Sub Makros1()
    Range("a2").Select
    With Range("a2:e16")
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, Formula1:="=A2="""""
        .FormatConditions(1).Interior.ColorIndex = 3
    End With
End Sub

или
Код
Sub Makros2()
    With Range("a2:e16")
        .SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 3
    End With
End Sub
Программно прописать в combobox выбор элемента из списка
 
Не знаю, или это вы имеете в виду (?), но попробуйте:
Код
Option Explicit

Dim tbl()
Dim vybor$
Dim blokiruy As Boolean

Private Sub UserForm_Initialize()
    blokiruy = True
    With ThisWorkbook.Sheets("List1").Range("a1").CurrentRegion
        tbl = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Value
    End With
    With UserForm1
        .Caption = "Okno"
        With .ComboBox1
            .List() = tbl
            .ListIndex = -1
        End With
        With .ListBox1
            .List() = tbl
            .ListIndex = -1
        End With
    End With
    blokiruy = False
End Sub

Private Sub ComboBox1_Change()
    If blokiruy Then Exit Sub
    With UserForm1
        vybor = .ComboBox1.Value
        With .ListBox1
            .Value = vybor
            .SetFocus
        End With
    End With
End Sub
Ежедневное суммирование двух значений
 
"Если в это время файл закрыт" - с помощью скрипта "vbs". Он должен быть зарегистрирован в расписании задач.
Макрос, собирающий данные из разных файлов
 
и другой макрос
Наиболее быстрый способ удаления строк VBA
 
Код, аналогичный коду _Igor_61, попробуйте:
Код
Option Explicit

Sub bez_min_daty()
Dim r&, c%, i&, j%, k&, min_date, tbl_tmp(), tbl()
Dim tmr!: tmr = Timer

    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
        .EnableEvents = False: .Calculation = xlManual
    End With
    
    With Range("a1").CurrentRegion
        r = .Rows.Count - 1: c = .Columns.Count
        min_date = Application.Min(.Offset(1, 0).Resize(r, 1))
        tbl_tmp = .Offset(1, 0).Resize(r, c).Value
    End With
    
    For i = 1 To r
        If tbl_tmp(i, 1) <> min_date Then k = k + 1
    Next
    
    ReDim tbl(1 To k, 1 To c): k = 0
    
    For i = 1 To r
        If tbl_tmp(i, 1) <> min_date Then
            k = k + 1
            For j = 1 To c
                tbl(k, j) = tbl_tmp(i, j)
            Next
        End If
    Next
    
    Erase tbl_tmp
    
    With Range("a1").CurrentRegion.Offset(1, 0)
        .Resize(r, c).Clear: .Resize(k, c).Value = tbl
    End With
    
    Erase tbl
    
    With Application
        .Calculation = xlAutomatic: .EnableEvents = True
        .DisplayAlerts = True: .ScreenUpdating = True
    End With
    
    MsgBox "Ves' protsess prodolzhalsya: " & CStr(Round(Timer - tmr, 4)) & " s", vbOKOnly, "Info !"
End Sub
Изменено: ocet p - 5 Окт 2018 01:32:26
Автоматическое копирование данных в умную таблицу из двух и более умных таблиц.
 
Если макрос, так например (в половине автоматически):
Код
Option Explicit

Sub tablitsy()
Dim stroky As Long
Dim tbl
Dim objList As Worksheet

    For Each objList In ThisWorkbook.Worksheets
        If objList.Name <> "Svodnaya" Then
            tbl = objList.ListObjects.Item(1).DataBodyRange.Value
            With Sheets("Svodnaya").ListObjects.Item(1)
                stroky = .Range.Rows.Count
                If stroky > 2 Then stroky = stroky + 1
                'ili
                'On Error Resume Next
                '    stroky = .DataBodyRange.Rows.Count
                '    If Err.Number = 0 Then stroky = stroky + 2 Else stroky = 2
                'On Error GoTo 0
                .Range.Cells(stroky, 1).Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
                'ili
                '.Range(stroky, 1).Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
            End With
        End If
    Next
End Sub
Изменено: ocet p - 9 Сен 2018 16:24:47
Сбор данных с 10 листов
 
Используя формулы или vba ?
Если в ячейке значение, то выводить А2, если нет то В2.
 
Достаточно:
=ЕСЛИ(A2<>"";A2;B2)

( IF(A2<>"";A2;B2) )
Формат даты в комбобоксе формы
 
zasada,
возможно, какая-то процедура активируется много раз, а не только один
удалите конфиденциальные данные и вставте пример файла с макросами
Ошибка работы макроса (на разных компьютерах) при выполнении переноса данных
 

В начале простите ... не знаю почему это может так происходить (возможно потому, что вы постоянно открываете соединения "cn.Open strCon" и не закрываете их) ...

... но сократите свой код немножко, используя какой-то цикл, например 'For...Next'. У вас 22 почти одинаковых раздела/секции, так например можно бы:

("strTableName" i "rng" установлено по диапазонах ячеек)

Код
Option Explicit

Sub macro_macro() 'Îáíîâëaíea_ëenoîâ_1() ' ?

    Const strFile$ = "\\Polymer2000\áaçu erp\Nëóaáa Ea÷anoâa\?AANO?U çaá?aeîâaííîé iîeóiíîé i?îäóeöee\" & _
                        "Ô-9-49 ?aano? çaá?aeîâaííîé iîeóiíîé i?îäóeöee ía ânao ýoaiao i?îeçâîänoâa.xlsm"
    
    Dim strCon$: strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";"
    
    Dim strTableName: strTableName = Array("ÔIÔ", "CNBM", "Hydro", "3I", "Henkel", "8113", "AIOO-Eíâano", "Qindaî", _
                            "Shanghai", "Symetal", "Assan", "Effegidi", "Dong-Il", "Áeaeniëaí", "CarWare", _
                            "Flex", "N?? shur", "Petlar", "Jindal", "Tagleef", "Treofan", "N?? Flex")
    
    Dim rng: rng = Array("$A2:T500", "$A2:AD500", "$A2:AD500", "$A2:AD500", "$A2:AG500", "$A2:AH500", "$A2:AN500", "$A2:AN500", _
                            "$A2:AN500", "$A2:AN500", "$A2:AO500", "$A2:AO500", "$A2:AO500", "$A2:AP500", "$A2:AP500", _
                            "$A2:AP500", "$A2:AP500", "$A2:AP500", "$A2:AQ500", "$A2:AQ500", "$A2:AQ500", "$A2:AT500")
                            
    Dim strSQL1$, i&, indx&: indx = UBound(strTableName)
    
    Dim cn As ADODB.Connection: Set cn = CreateObject("ADODB.Connection")
    Dim rs As ADODB.Recordset: Set rs = CreateObject("ADODB.Recordset")
    
    Application.Calculation = xlManual
    Sheets("Iîaaëaíey-i?aäëîaaíey").Activate
    
    cn.Open strCon
    
    For i = 0 To indx
        strSQL1 = "SELECT * FROM [" & strTableName(i) & rng(i) & "]"
        rs.Open strSQL1, cn
        Worksheets(strTableName(i)).Range("A2").CopyFromRecordset rs
        rs.Close
    Next
    
    Set rs = Nothing
    cn.Close: Set cn = Nothing
    
    Application.Calculation = xlAutomatic

End Sub

Это всего лишь пример, а не решение, не знаю, будет ли это работать или в космос полетит ... : /
Изменено: ocet p - 29 Авг 2018 18:59:48 (коррекция кода (Set rs = Nothing))
Проверка и копирование определенного количества символов, разделенных запятой(любым другим символом)
 
Значит это вариант 2:
Код
Option Explicit

Sub a_b_c_v0()
Dim JachList1, JachList2
Dim indx As Long, i As Long, r As Long: r = 1
Dim shL1 As Worksheet: Set shL1 = ThisWorkbook.Sheets("List1")
Dim shL2 As Worksheet: Set shL2 = ThisWorkbook.Sheets("List2")

    If Trim(shL2.Cells(1, 1).Value) <> "" Then
        JachList2 = Split(shL2.Cells(1, 1).Value, ",", -1, 1)
        indx = UBound(JachList2)
        
        Do Until Trim(shL1.Cells(r, 1).Value) = ""
            JachList1 = Trim(CStr(shL1.Cells(r, 1).Value))
            
            For i = 0 To indx
                If JachList1 = Trim(CStr(JachList2(i))) Then Exit For
            Next
            
            If i > indx Then shL2.Cells(1, 1).Value = Trim(shL2.Cells(1, 1).Value) & "," & JachList1
            
            r = r + 1
        Loop
        
    End If
    
    Set shL1 = Nothing
    Set shL2 = Nothing
End Sub
Проверка и копирование определенного количества символов, разделенных запятой(любым другим символом)
 
Ваше описание нечеткое/неясна. Что дальше:
1) сравнение "А1" на Лист1 с "А1", "А2", "А3", "А4", ... и так дальше, на Лист2, потом сравнение "А2" на Лист1 с "А1", "А2", "А3", "А4", ... и так дальше, на Лист2 ... и так дальше ?
Или
2) сравнение "А1", "А2", "А3", "А4", ... и так дальше, на Лист1 с (только) "А1" на Лист2 ?
Или
3) сравнение "А1" на Лист1 с "А1" на Лист2, потом сравнение "А2" на Лист1 с "А2" на Лист2 ... и так дальше ?
Пригодился бы какой-то пример (результатов) за несколько записей.
Преобразование числовой даты в название дня недели в VBA
 
;)
Код
Choose(DatePart("w", #8/19/2018#, vbMonday, vbFirstJan1), "Mo", "Tu", "We", "Th", "Fr", "Sa", "Su")
Как перенести данные с одного листа на несколько последующих
 
Например:
Код
Option Explicit

Sub aaaaaa()
    Dim r As Integer: r = 1
    Do Until Trim(Sheets("СВОД").Cells(r, 1).Value) = ""
        ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count), Count:=1, Type:=xlWorksheet).Name = Trim(Sheets("СВОД").Cells(r, 1).Value)
        Range("a3").Value = Sheets("СВОД").Cells(r, 2).Value
        r = r + 1
    Loop
End Sub
Изменено: ocet p - 8 Авг 2018 17:09:13
Копирование листа в другую книгу без расширения, или изменения макроса
 
Например:
Код
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Left(importWB.Name, Len(importWB.Name) - InStrRev(importWB.Name, ".", -1, 1) + 1)
[ Закрыто] Google shit | Работа с онлайн документом под названием гугл таблица, формулой например суммесли, Тянуть из одной книги в другую | Для модератора: Необходимо в одной книге гугл таблиц, написать формулу которая будет исходя из определённых условий подсчитывать данные во второй книге гугл таблиц
 
Цитата
cratas.thymos написал:
shit | Работа с ....
Цитата
cratas.thymos написал:
Нашел в интернете формулу impotent ...
ой ... ну что ж ... простите ...  :) ... но если это "shit" как пишете так вам осталось только одно решение ... ой ... будте сильним и мужским ... вам надо ... спустить воду в унитазе ... ... ну а если  :)  "impotent" ...так просто ... ой ... синие таблетки принимать ... ну и решение тогда будет ... как бы это сказать ... хмм... несомненно, "простым" ...  :oops:  ...  :) ...
Макрос копирование значений ячеек в открытую книгу из другой, Исправить код
 
Цитата
yelena321 написал:
макрос дает ошибку. Скрины в файле
???

Ну, и где эти скрины ?
Там только какие-то ... "gfdgddfgdfg" ... как бы будто кто-то пытался проглотить горячую цветную капусту ... ?
Какая там ошибка ?
Макрос копирование значений ячеек в открытую книгу из другой, Исправить код
 
Вы можете, например, таким образом:
Код
Option Explicit
Option Private Module

Sub otkroy_kopiruy_zakroy()
Dim kngDostup As String, kngList As String, kngDiapazon As String, kngMestoKop As String
Dim tbl() As Variant
Dim istdann As Object

Const bazList As String = "List2"       'Nastroyki

    Application.ScreenUpdating = False
    
    With ThisWorkbook
        With .Sheets(bazList)
            kngDostup = .Range("A1").Value
            kngList = .Range("A2").Value
            kngDiapazon = .Range("A3").Value
            kngMestoKop = .Range("A4").Value
        End With
        
        Set istdann = GetObject(kngDostup)
        'Windows(istdann.Name).Visible = True
        tbl = istdann.Sheets(kngList).Range(kngDiapazon).Value
        istdann.Close SaveChanges:=False
        Set istdann = Nothing
        
        With .Sheets(kngMestoKop)
            With .Range("A1")
                .Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
                .CurrentRegion.EntireColumn.AutoFit
            End With
            Erase tbl
            .Activate
        End With
    End With
    
    Application.ScreenUpdating = True
End Sub
Как открыть новую вкладку в браузере
 
1.
https://developer.mozilla.org/en-US/docs/Mozilla/Command_Line_Options

2. ?
Код
Sub Command_Com_Tor_b()
    'curr_row = ActiveCell.Row '?
    'curr_col = ActiveCell.Column '?
    
    'command_dos = Cells(ActiveCell.Row, ActiveCell.Column).Value '??
    
    command_dos = ActiveCell.Value
    '...
End Sub
?:sceptic: ?
Дополнительное меню при правом клике мыши
 
Цитата
aimv написал:
есть маленький макрос
"Workbook_SheetBeforeRightClick" будет лучше, чем "Workbook_Open", больше возможностей управления:
Код
    If TypeName(Sh) = "Worksheet" Then
        On Error Resume Next
        Set objLst = Target.ListObject
        If Not objLst Is Nothing Then
            CBstrDesc = "List Range Popup"
        Else
            CBstrDesc = "Cell"
        End If
        On Error GoTo 0
        '...
        Set prygun = Application.CommandBars(CBstrDesc) ... 'и так далее
        '...
    End If
Страницы: 1 2 3 4 След.
Наверх