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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 207 След.
Удаление строк после ячейки с определенными данными
 
Цитата
как макросом удалить 10 пустых строк, после строки
Код
Sub DelAfterWsego()
Dim FoundWsego As Range
    Set FoundWsego = Columns("A").Find("Всего", , xlValues, xlWhole)
    If Not FoundWsego Is Nothing Then
      Rows(FoundWsego.Row + 1 & ":" & FoundWsego.Row + 10).Delete
    End If
    Range("A1").Select
End Sub
Сокращение времени при поиске значения ячейки в диапазоне
 
Цитата
сократить скорость выполнения макроса
https://www.excel-vba.ru/chto-umeet-excel/kak-uskorit-i-optimizirovat-kod-vba/
Макрос. Копирование данных в лист другого файла с изменяющимся названием
 
Цитата
Если лист с таким именем существует, он не делает копирование данных
Макрос в сообщении 15 делает проверку наличия листа и, если листа нет, то добавляет его в книгу. А копирование данных добавьте в код
после проверки наличия листа
Макрос. Копирование данных в лист другого файла с изменяющимся названием
 
Цитата
на счет проверки наличия листа.
Код
Sub Copy_Data()
Dim sh_src As Worksheet, sh_res As Worksheet
 Set sh_src = Workbooks("Book1.xlsm").Worksheets("Invoices")
Dim Sh_name As String
    Sh_name = Workbooks("Book1.xlsm").Worksheets("Macro").Range("E6").Text
     Workbooks("Book2.xlsm").Activate
      If Not SheetExist(Sh_name) Then  'функция проверки наличия листа в файле
        sh_src.Copy After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = Sh_name
      End If
   MsgBox ("INCOICES DOWNLIADING - Complete!")
End Sub

     'функция проверки наличия листа в файле, лист есть - true
Function SheetExist(iName As String) As Boolean
    On Error Resume Next
    With Worksheets(iName): End With
    SheetExist = (Err = 0)
End Function

Макрос. Копирование данных в лист другого файла с изменяющимся названием
 
Цитата
вставить с 6й колонки в последнюю строку
Последняя строка в столбце F
Код
iLastRow = Cells(Rows.Count, "F").End(xlUp).Row
Вставляйте после копирования в
Код
sh_res.Cells(iLastRow,"F")

Макрос. Копирование данных в лист другого файла с изменяющимся названием
 
Неплохо было бы сделать проверку наличия во второй книге листа Sh_name
Макрос. Копирование данных в лист другого файла с изменяющимся названием
 
Цитата
ругается на последнюю строку
При пустом листе sh_res неправильно определяется последняя строка
Код
sh_res.[A1].End(xlDown)(2)
Как перенести данные одного столбца в другой в алфавитном порядке?
 
Цитата
На фото видно один ник на первой строчке второй на 40
Ни фото не вижу, ни примера как предписывают правила
Макрос. Копирование данных в лист другого файла с изменяющимся названием
 
Код
Dim Sh_name as String
Sh_name= Workbooks("Book1.xlsm").Worksheets("Macro").Range("E6").Text
Макрос. Копирование данных в лист другого файла с изменяющимся названием
 
Код, приведенный в сообщении 1, не совпадает с кодом из файла
Как удалить все символы в строке после определённого знака, Составление функций для обработки строк в ячейке
 
Цитата
чтоб после / всё было удалено
Может быть до /
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 1 To iLastRow
    Cells(i, "B") = Mid(Cells(i, "A"), InStrRev(Cells(i, "A"), "/") + 1)
  Next
End Sub
найти 19 цифр в тексте, структура одинаковая у цифр
 
Цитата
если несколько кадастровых в одной ячейке
Запустить макрос, кадастровые номера выделяются из ячейки и записываются в этой же строке, начиная со столбца В и далее
Код
Sub iKadastrNomer()
Dim mo As Object
Dim n As Integer
Dim i As Long
Dim j As Integer
 With CreateObject("VBScript.RegExp")
   .Global = True
   .MultiLine = True
   .Pattern = "\d{10}:\d{2}:\d{3}:\d{4}"
  For i = 2 To 7
     If .test(Cells(i, 1)) Then
       Set mo = .Execute(Cells(i, 1))
           j = 2
         For n = 0 To mo.Count - 1
           Cells(i, j) = mo(n)
           j = j + 1
         Next
    End If
   Next
 End With
End Sub
найти 19 цифр в тексте, структура одинаковая у цифр
 
Приведите пример когда несколько кадастровых в одной ячейке
для одного номера UDF
Код
Function iKadastrNomer(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\d{10}:\d{2}:\d{3}:\d{4}"
     iKadastrNomer = .Execute(cell)(0)
 End With
End Function

VBA Как округлить значение в меньшую сторону с определенной точностью с помощью кода
 
WorksheetFunction.RoundDown
Переместить, удалить значение внутри ячейки
 
Artsem K,написал
Цитата
мож кинет кто эксель с поддержкой макросов.
Я вам в сообщении #22 как раз выкладывал файл с макросом, что не получилось?
Переместить, удалить значение внутри ячейки
 
Вставьте макрос в стандартный модуль своего файла и запустите
Код
Sub Zamena()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For i = 4 To iLastRow
    Cells(i, "B") = Split(Cells(i, "A"), ",")(0) & "," & Split(Cells(i, "A"), ",")(1) & "," & Split(Cells(i, "A"), ",", 5)(4) & "," & Split(Cells(i, "A"), ",")(2) & "," & Split(Cells(i, "A"), ",")(3)
  Next
End Sub
Переместить, удалить значение внутри ячейки
 
Цитата
макросы почему-то недоступны
При запуске файла .xls в Excel 2007 и выше, он открывается в режиме совместимости и с предупреждением системы безопасности,
что запуск макросов отключен. Зайдите в Параметры... и включите макросы (Включить это содержимое).
Сохранить книгу как... Книга Excel с поддержкой макросов
Переместить, удалить значение внутри ячейки
 
Цитата
а как добавить значения, которые ниже 1000-й строки? добавил-протянул...формула новые значения не подхватила
Добавьте свои значения и запустите макрос Zamena
Формул в файле нет, так что протягивать нечего
Переместить, удалить значение внутри ячейки
 
Цитата
скачивать ваш прикрепленный файл?
Да, я там сократил количество строк до 1000, чтобы уложиться в разрешенный размер
Рассчитать возраст по персональному коду
 
Используйте Разндат(дата1;дата2;"y")

ну а, если, решено, то поделитесь решением здесь
Изменено: Kuzmich - 28 Апр 2019 20:27:51
Переместить, удалить значение внутри ячейки
 
Почему в столбце А -volume
         а в столбце Н - vol
где истина?
Результат работы макроса в столбце В
Изменено: Kuzmich - 28 Апр 2019 15:30:10
Переместить, удалить значение внутри ячейки
 
Цитата
попадаются строки, где количество символов разное
А число значений, разделенных запятой, всегда шесть?
Переместить, удалить значение внутри ячейки
 
Artsem K, похоже, что в теме Заменить два первых значения в ряде чисел, разделенных запятыми вы так и не осилили решение макросом.
В этой теме тот же подход
В примере в столбце превратить в... указано date,open,high,low,close,volume и нет упоминания об удалении
Код
Sub Zamena()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For i = 4 To iLastRow
        Cells(i, "B") = Split(Cells(i, "A"), ",", 4)(0) & "," & Split(Cells(i, "A"), ",", 4)(3) & "," & Split(Cells(i, "A"), ",", 4)(1) & "," & Split(Cells(i, "A"), ",", 4)(2)
  Next
End Sub
Изменено: Kuzmich - 27 Апр 2019 20:47:28 (Убрал лишнее значение)
Ежедневный сбор данных из таблиц и объединение в одну
 
Sheriff,  в файлах.xlsx макросы не живут
Разделение листа на отдельные книги по критерию
 
Цитата
разбить этот файл на классы
Код
Sub Raznesti()
Dim Rng As Range
Dim iLastRow As Long
Dim iName As String
Dim pMain As Worksheet
Application.ScreenUpdating = False
  Set pMain = ThisWorkbook.Worksheets("pMain")
  iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
    For Each Rng In Range("B3:E" & iLastRow).SpecialCells(xlCellTypeConstants, 2).Areas
     iName = Rng.Cells(0, 0)                          'очередной класс
       Workbooks.Add (xlWBATWorksheet)                'добавляем книгу с одним листом
        pMain.Range("A1:H1").Copy                     'копируем шапку таблицы
        Cells(1, 1).PasteSpecial xlPasteColumnWidths  'ширина столбцов в новой книге
        Cells(1, 1).PasteSpecial xlPasteValues        'вставляем шапку
        Rng.Copy Cells(2, 2)                          'копируем диапазон очеред.класса
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & iName & ".xls"
        ActiveWorkbook.Close SaveChanges:=True        'сохраняем книгу с именем класса
    Next
Application.ScreenUpdating = True
End Sub
Файлы с именем класса создаются в той же директории, где и исходный файл
Заменить два первых значения в ряде чисел, разделенных запятыми
 
Читайте
https://www.planetaexcel.ru/techniques/3/59/
Заменить два первых значения в ряде чисел, разделенных запятыми
 
Код
Sub Zamena()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For i = 1 To iLastRow
    Cells(i, "B") = Cells(i, "F") & "," & Split(Cells(i, "A"), ",", 3)(2)
  Next
End Sub
Результат в столбце В
Разделение листа на отдельные книги по критерию
 
Цитата
незнаю с чего начать может кто напрвит на путь истинный
Пишите макрос.
1.Определяете диапазон ячеек, принадлежащих определенному классу.
2.Создаете новую книгу с одним листом и копируете в нее этот диапазон.
3.Присваиваете книге имя соответствующего класса.
4.Сохраняете книгу в нужном месте.
5. Переходите к пункту 1 для следующего класса
Разделить каждую строку из одной ячейки в отдельный столбец
 
Цитата
раскидать каждую строку/характеристику в отдельный столбик
UDF, каждую в свой столбец
Код
Function Tip(cell As String) As String
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "Тип:(.+)(?=\n)"
     If .Test(cell) Then
       Tip = WorksheetFunction.Trim(.Execute(cell)(0).SubMatches(0))
     Else
       Tip = "Нет типа"
     End If
 End With
End Function

Function Marka(cell As String) As String
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "Торговая марка:(.+)(?=\n)"
     If .Test(cell) Then
       Marka = WorksheetFunction.Trim(.Execute(cell)(0).SubMatches(0))
     Else
       Marka = "Нет марки"
     End If
 End With
End Function
Остальные характеристики аналогично
Функция для извлечения значения из массива текста
 
Цитата
написать Функцию в VBA
UDF
Код
Function iText(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "z0[0-9a-z]{6}"
     If .test(cell) Then
      iText = UCase(.Execute(cell)(0))
     Else
       iText = "null"
     End If
 End With
End Function
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 207 След.
Наверх