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

Страницы: 1 2 3 4 След.
Вставка рисунка в ячейку с удалением предыдущего рисунка, с небольшим отступом от краев.
 
Например:
Код
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
Некорректно экспортирует в CSV файл
 
Что такое "инт.магазин" и как вы сохраняете файл "csv" / записуете в файл "csv" ? Используя макрос, вручную ?
Искомое значение из textbox, Не получается в впр вставить значение из textbox
 
Попробуйте
Код
'Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = 13 Then
        If Trim(UserForm1.TextBox1.Value) = "" Then
            MsgBox ("введите артикул")
        Else
            'ActiveCell.FormulaR1C1 = "=VLOOKUP(UserForm1.TextBox1.Value,'Паллеты к отгрузке'!C[-10]:C[-8],3,0)"
            ActiveCell.FormulaR1C1 = "=VLOOKUP(" & Chr(34) & Trim(UserForm1.TextBox1.Value) & Chr(34) & ",'Паллеты к отгрузке'!C[-10]:C[-8],3,0)"
        End If
    End If
End Sub
Найти значение в таблице, которое может находится в любой ячейке таблицы.
 
макросы проще ...  :)
Код
Option Explicit

Sub poisk()
Dim fnd As Range, cl%, rw&, r&: r = 16
Const adrRngTBL1$ = "B2:E12"

    Do Until Cells(r, "B").Value = ""
        Set fnd = Range(adrRngTBL1).Find(Cells(r, "B").Value, Range("B2"), xlValues, xlWhole, xlByRows)
        If Not fnd Is Nothing Then
            rw = fnd.Row: cl = fnd.Column: Set fnd = Nothing
            With Cells(r, "B")
                .Offset(0, 1).Value = Cells(rw, "G").Value
                .Offset(0, 2).Value = Cells(1, cl).Value
                .Offset(0, 3).Value = Cells(rw, cl + 7).Value
            End With
        End If
        r = r + 1
    Loop
End Sub
пс: что такое "габваг" ? ...  : / ?
VBA скрипт, который переставляет колонку? Меняет местами 2 колонки?
 
Цитата
vkcntoread написал:
Меняет местами 2 колонки
Код
Sub Makros()
    Columns("B:B").Cut
    Columns("O:O").Insert Shift:=xlToRight
    Columns("O:O").Cut
    Columns("B:B").Insert Shift:=xlToRight
End Sub
Работа с датами 1900 года в Excel через VBA, Как VBA работает с датами 1900 года. Хочу понять.
 

Прочитайте например:
http://www.exceluser.com/formulas/earlydates.htm

Это вопрос/тема река. Используйте другие функции, а не "CDate":

DateDiff
DateAdd
DateValue
и обычное сложение и вычитание в алгоритмах, вычисляющих дату около 1900 года и ранее.

Для просмотра также:

високосные годы
http://spreadsheetpage.com/index.php/file/extended_date_functions_xdate/
https://support.microsoft.com/en-us/help/245104/how-to-calculate-ages-before-1-1-1900-in-excel

и другие.

Вставка картинки без обновления с источником, При вставке картинки она обновляется вместе с исходными данными
 
Попробуйте этот "кодер" таким образом - смотрите в ссылке.
Перенос фигур по условию.
 
Цитата
RenatKZ написал:
если слово "есть" значить передвинуть фигуру в этой же строке в правую сторону

"Фигур на фигур", говорил святой Игорь ... :)


Это можно бы было и сделать,
1. Если будет порядок в вашей книжке, но у вас:
а) высота это не высота
б) глубина у вас это высота, и это не везде
в) ширина меняется местами с глубиной (строка 592, 593)

2. При каждом изменении, связанном с добавлением или сбросом размеров, добавлением или удалением строк, изменением кодовых номеров вам придётся удалять и воссоздавать все прямоугольники, чтобы их нумерация соответствовала числу строки, в которой данный прямоугольник находится, иначе ничего с того не будет, это не графическая программа, это просто электронная таблица.

3. Другие о чём теперь не знаем.

И это будет "болезненная работа" с этими фигурами.

Определение что в найденных частях строки. отсутствуют ее начальные части VBA
 
к пункту 1

Я не совсем понимаю:
чего код не находит ?
и
при каких обстоятельствах ?

может быть, какой-то пример в книге excel ?

к пункту 2
Код
Option Explicit

Sub naydi_chego_net()
Dim vim%, i%, chsl_nenayd%, strk&: strk = 1
Dim itogo&: itogo = 0                           'itogo ne naydennykh
Dim tkct$, tbl
Dim nayd As Range

    Application.ScreenUpdating = False
    Do Until Trim(Range("A" & strk).Value) = ""
        chsl_nenayd = 0                         'chislo ne naydennykh
        tkct = ""
        tbl = Split(Trim(Range("A" & strk).Value), ",", -1, 1)
        vim = UBound(tbl)
        For i = 0 To vim
            Set nayd = Range("b" & strk & ":p" & strk).Find(Trim(tbl(i)), Range("b" & strk), xlValues, xlWhole, xlByColumns)
            If nayd Is Nothing Then
                chsl_nenayd = chsl_nenayd + 1   'chislo ne naydennykh
                tkct = tkct & "," & Trim(tbl(i))
                If Left(tkct, 1) = "," Then tkct = Right(tkct, Len(tkct) - 1)
                Range("q" & strk).Value = tkct
            End If
            Set nayd = Nothing
        Next
        Range("r" & strk).Value = chsl_nenayd   'chislo ne naydennykh
        itogo = itogo + chsl_nenayd             'itogo ne naydennykh
        strk = strk + 1
    Loop
    Range("r" & strk).FormulaR1C1 = "=sum(r[" & 1 - strk & "]c:r[-1]c)" 'itogo ne naydennykh - variant I
    Range("r" & strk).Offset(0, 1).Value = itogo                        'itogo ne naydennykh - variant II
    Application.ScreenUpdating = True
End Sub
Страницы: 1 2 3 4 След.
Наверх