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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 207 След.
Перемещение слов по очереди в одной ячейке
 
Цитата
В пределах одной ячейки перемещать слова по очереди
Код
Sub Перестановка()
Dim arr
   arr = Split(ActiveCell, " ", 2)
   ActiveCell = arr(1) & " " & arr(0)
End Sub
VBA: разбивка с помощью макроса объединенных ячеек
 
Цитата
чтобы он работал в конкретном выделенном столбце или, ещё лучше, диапазоне ячеек?
Так макрос и так работает с конкретным диапазоном ячеек от В2 и до последней ячейки в столбце В.
Cells(i, 2) - цифра 2 указывает на столбец В, если нужен другой столбец, то поменяйте цифру.
Или замените цикл For i = 2 To iLastRow на цикл по выделенному диапазону Selection. Удачи!
Объединить текст и число с разным размером шрифтов
 
Код
Sub FontSize()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 2 To iLastRow
    Cells(i, 16) = Cells(i, 2) & vbLf & "руб, 1 шт"
    Cells(i, 16).Font.Size = 27
    Cells(i, 16).Font.Bold = True
     With Cells(i, 16).Characters(Len(Cells(i, 2)) + 1, 10).Font
       .Size = 10
       .Bold = False
     End With
  Next
End Sub
VBA если ячейка заполнена
 
А как ваша тема "Собрать данные со всех листов в книге по критерию и перенести в единый лист с указанием листов" ?
VBA: разбивка с помощью макроса объединенных ячеек
 
Цитата
можно ли сделать эту операцию с помощью какого-либо макроса?
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim n As Integer
 iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
  For i = 2 To iLastRow
    If Cells(i, 2).MergeCells Then
      n = Cells(i, 2).MergeArea.Count
      Range(Cells(i, 2), Cells(i + n - 1, 2)).UnMerge
      Cells(i, 2).Resize(n) = Cells(i, 2)
    End If
  Next
End Sub
Собрать данные со всех листов в книге по критерию и перенести в единый лист с указанием листов
 
При активном листе РЕЗУЛЬТАТ запустите макрос
Код
ub Sbor()
Dim Sht As Worksheet
Dim iLastRow As Long
Dim iLR As Long
Dim Zavod As Range
  iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
  If iLastRow = 3 Then iLastRow = 4
  Range("C4:D" & iLastRow).Clear
    For Each Sht In Worksheets
      If Sht.Name <> "РЕЗУЛЬТАТ" Then
        With Sht
         Set Zavod = .Rows("11").Find("Завод", , xlValues, xlWhole)
          If Not Zavod Is Nothing Then
            iLR = .Cells(.Rows.Count, Zavod.Column).End(xlUp).Row
            iLastRow = Cells(Rows.Count, "C").End(xlUp).Row + 1
            .Range(.Cells(12, Zavod.Column), .Cells(iLR, Zavod.Column)).Copy Cells(iLastRow, "C")
            Cells(iLastRow, "D").Resize(iLR - 11) = Sht.Name
          End If
        End With
      End If
    Next
End Sub
Удаление строк после ячейки с определенными данными
 
Цитата
как макросом удалить 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 макросы не живут
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 207 След.
Наверх