Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 266 След.
Как убрать из формата ДАТА + ВРЕМЯ секунды
 
Цитата
убрать в обоих датах секунды
Код
=ЦЕЛОЕ(A1)=ЦЕЛОЕ(A2)
Разбить строку по ячейкам.
 
Результат заносится в столбец I
Код
Sub Konteiner()
Dim arr
Dim n As Long
Dim BeginNumber As Long
Dim iRow As Long
  arr = Split(WorksheetFunction.Trim(Split(Range("A24"), ":")(1)), ",")
    iRow = 25
  For n = 0 To UBound(arr)
    If InStr(arr(n), "-") > 0 Then     'есть перечень номеров
      BeginNumber = Split(arr(n), "-")(0)
      Cells(iRow, "I") = BeginNumber
      Do
        BeginNumber = BeginNumber + 1
        iRow = iRow + 1
        Cells(iRow, "I") = BeginNumber
      Loop While BeginNumber <> Split(arr(n), "-")(1) + 1
    Else
      Cells(iRow, "I") = arr(n)
      iRow = iRow + 1
    End If
  Next
End Sub
Удаление лишних символов в массиве данных, Удаление пробелов, запятых по условиям
 
Цитата
И есть ещё вариант чтоб он как-то перебирал построчно
Для столбца А
Код
Sub iPhraza_1()
Dim arr
Dim i As Long
Dim n As Long
Dim cell As String
 For i = 2 To 24
  If Not IsEmpty(Cells(i, "A")) Then
   arr = Split(Cells(i, "A"), ",")
   For n = 0 To UBound(arr)
     If arr(n) <> " " And arr(n) <> "" Then
       cell = cell & Application.Trim(arr(n)) & ","
     End If
   Next
     Cells(i + 24, "A") = Left(cell, Len(cell) - 1)
   End If
   cell = ""
  Next
End Sub
Удаление лишних символов в массиве данных, Удаление пробелов, запятых по условиям
 
Пусть ваша фраза в ячейке А1, тогда после выполнения макроса результат в В1
Код
Sub iPhraza()
Dim arr
Dim i As Long
Dim cell As String
   arr = Split(Range("A1"), ",")
   For i = 0 To UBound(arr)
     If arr(i) <> " " And arr(i) <> "" Then
       cell = cell & Application.Trim(arr(i)) & ","
     End If
   Next
     Range("B1") = Left(cell, Len(cell) - 1)
End Sub
Сортировка по заданому перечню, Отсортировать список с разных листов, на первом листе по перечню из колонки А
 
Цитата
Хоть на половину меньше работы будет
Макрос в стандартный модуль, запускать при активном листе Общая
Код
Sub PoiskTER()
Dim Sht As Worksheet
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim Col_TER As Integer
     iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
     Range("C3:D" & iLastRow + 1).ClearContents
     Range("F3:G" & iLastRow + 1).ClearContents
     For i = 3 To iLastRow Step 2
       Cells(i, "E") = 0
       Cells(i, "H") = 0
     Next
  For Each Sht In Worksheets                            'цикл по всем листам
    If Sht.Name <> "Общая" Then
      With Sht
       Set FoundCell = .Rows("3:6").Find("Шифр и номер позиции норматива", , xlValues, xlWhole)            'поиск
        If Not FoundCell Is Nothing Then
          Col_TER = FoundCell.Column
          For i = 3 To iLastRow Step 2
          If Not Cells(i, "A") Like "цена поставщика*" Then
           Set FoundCell = .Columns(Col_TER).Find(Cells(i, "A"), , xlValues, xlWhole)
           If Not FoundCell Is Nothing Then
             If Sht.Name = "Лист2" Then
              .Range(.Cells(FoundCell.Row, "C"), .Cells(FoundCell.Row + 1, "D")).Copy Cells(i, "C")
              Cells(i, "E") = Replace(.Cells(FoundCell.Row, "E"), ".", ",")
             Else
              .Range(.Cells(FoundCell.Row, "C"), .Cells(FoundCell.Row + 1, "D")).Copy Cells(i, "F")
              Cells(i, "H") = Replace(.Cells(FoundCell.Row, "E"), ".", ",")
             End If
           End If
          End If
           Set FoundCell = Nothing
          Next
        End If
        Set FoundCell = Nothing
      End With
    End If
  Next
End Sub
Сортировка по заданому перечню, Отсортировать список с разных листов, на первом листе по перечню из колонки А
 
Можно не присваивать ТЕР, а добавить цена поставщика_1, цена поставщика_2 и т.д. и подтягивать данные
по этому параметру
Сортировка по заданому перечню, Отсортировать список с разных листов, на первом листе по перечню из колонки А
 
Пишем макрос с циклом по имеющимся ТЕР и по всем листам, кроме "Общая".
Так по крайней мере будут подтянуты данные по всем ТЕР.
А там где стоит цена поставщика можно присвоить свой ТЕР?
Сортировка по заданому перечню, Отсортировать список с разных листов, на первом листе по перечню из колонки А
 
А работы, приведенные на листе 1, на других листах встречаются не более одного раза?
Сортировка по заданому перечню, Отсортировать список с разных листов, на первом листе по перечню из колонки А
 
Цитата
На счет шифра ТЕР,
Сделайте пример с шифром на первом листе, будем думать как быть дальше
Сортировка по заданому перечню, Отсортировать список с разных листов, на первом листе по перечню из колонки А
 
Цитата
основной перечень, чуть чуть отличается от текста наименования работ на листах 2,3
Но шифр (ТЕР) у этих работ должен быть одинаков. На листе 1 введите столбец с шифром работ и по этому
шифру подтягивайте данные с других листов.
И старайтесь избавиться от объединенных ячеек. Удачи!
перенос данных из ячеек на другой лист, Задача данные из ячеек b1-b20 перенести на лист 2
 
Вы еще в прошлой теме не ответили, а создаете новую.
Проблемы печати, Теряется часть таблицы
 
Цитата
Как можно исправить?
У вас область печати задана А2:АТ39, поэтому и режется.
Копирования ячейки из пересечения в не одинарной таблице
 
Цитата
Таблицу с листа 2 я регулярно вставляю из другого отчета
Макрос в стандартный модуль, запускать при активном листе 1 лист
Код
Sub BiletTowar()
Dim iLastRow As Long
Dim List2 As Worksheet
  Set List2 = ThisWorkbook.Worksheets("2 лист")
  With List2
   iLastRow = .Columns("B").Find("билет", .Range("B1"), xlValues, xlWhole, xlByRows, xlPrevious).Row
     Range("B4") = .Cells(iLastRow, "I")
     Range("B5") = .Cells(iLastRow + 1, "I")
  End With
End Sub
Появление лишних знаков после 0, При суммировании ряда чисел округлённых 0,00 вдруг появляются числа 7 знаков после нуля
 
Цитата
вторая цифра после запятой нужна точная, без всяких округлений
Может использовать функцию
Format(cell, "#,##0.00")
Проверка наличия значения в ячейке, нужно проверить ячейку на наличие в нем числа
 
Код
Sub iFormula()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
  For i = 2 To iLastRow
    If Not IsEmpty(Cells(i, "A")) Then
      Cells(i, "C") = Cells(i, "B") * 100
    Else
      Cells(i, "C") = Cells(i, "B") * 150
    End If
  Next
End Sub
Появление лишних знаков после 0, При суммировании ряда чисел округлённых 0,00 вдруг появляются числа 7 знаков после нуля
 
WorksheetFunction.Round
поиск значения по таблице, Нужно что бы по значению градуса в ячейке по G5 был найден к Коэфф. Уклона по таблице
 
В ячейке G5 с помощью проверки данных делаем список из возможных коэффициентов
В модуль листа макрос
Код
Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("G5")) Is Nothing Then
    Application.EnableEvents = False
 Dim found_koef As Range
  End If
    Set found_koef = Columns(1).Find(Target, , xlValues, xlWhole)
    Target.Offset(, 1) = Cells(found_koef.Row, 5)
    Application.EnableEvents = True
End Sub
Проверить в нужном ли формате записана дата в ячейке
 
UDF
Код
Function iDate(cell$) As Date
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "(([0-2]?\d{1})|([3][0,1]{1}))\.[0,1]?\d{1}\.(([1]{1}[9]{1}[9]{1}\d{1})|([2-9]{1}\d{3}))"
   If .test(cell) Then
       iDate = .Execute(cell)(0)
   Else
     iDate = ""
   End If
 End With
End Function
Сохранение данных из определенных ячеек.
 
Цитата
Возможно ли
В модуль листа
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("A1")) Is Nothing Then
    Application.EnableEvents = False
Dim iLastCol As Long
    iLastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    Cells(1, iLastCol + 1) = Target
 End If
    Application.EnableEvents = True
End Sub
Сбор данных с нескольких листов на один
 
Кросс http://www.excelworld.ru/forum/10-50657-1
Проварка номера Container,a, Проверра фората написания контеинера
 
Цитата
недо макрос ,чтоб проверил написание номера контеинкра в одной ячейке
В модуль листа
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "[A-Z]{4}\d{7}"
   If .test(ActiveCell) Then
     MsgBox "Правильный ввод"
   Else
     MsgBox "Ошибка при вводе"
   End If
 End With
End Sub
Вставить под таблицей все строки, которые содержат в одном из столбцов ключевое слово
 
sokol92, написал
Цитата
К сожалению, не так:
Полностью с вами согласен, просто предположил, что у ТС до этого параметр был xlPart
Цитата
как сделать так, чтобы во вставляемых строках в ячейках 16 -17-18 столбцов прописывалось : в 16- "зеленый"; 17-"синий" ;18 -"последний"; и так в каждой вставляемой строке?
Попробуйте добавить в код соответствующие строки
Код
    Do
      lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
      Range(Cells(c.Row, 1), Cells(c.Row, 26)).Copy Cells(lLastRow + 1, 1)
        Cells(lLastRow + 1, 17) = "Синий"
      Range(Cells(c.Row, 1), Cells(c.Row, 26)).Copy Cells(lLastRow + 2, 1)
        Cells(lLastRow + 2, 18) = "Последний"
        Cells(c.Row, 16) = "Зеленый"
      Set c = .FindNext(c)
      If c Is Nothing Then Exit Do
    Loop While c.Address <> firstResult
Вставить под таблицей все строки, которые содержат в одном из столбцов ключевое слово
 
Boris DIMA,
Цитата
вопро по этой строке:
Код
Set c = .Find("+пакетик", LookIn:=xlValues)

У метода Find есть параметр LookAt, который определяет:
искать целиком элемент данных или его часть.
По умолчанию используется xlPart
Очистка диапазона при наличии в этом диапазоне пустой ячейки (VBA)
 
Цитата
В диапазоне F2:F4 оказалась пустая ячейка (F3)
Код
Sub iEmptyCell()
  If WorksheetFunction.CountA(Range("F2:F4")) = 3 Then
    '
  Else
    MsgBox "В диапазоне F2:F4 есть пустая ячейка"
  End If
End Sub
Как макросом считать суммы каждой n-й строки или столбца?, Сумма столбца или строки по условиям
 
Кросс http://www.excelworld.ru/forum/10-50495-1
Вставка пустой строки по условию
 
Код
Sub InsertRow()
Dim iLastRow As Long
Dim i As Long
    iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    For i = iLastRow To 2 Step -1
      If Cells(i, 2) <> Cells(i - 1, 2) Then
        Rows(i).Insert
      End If
    Next
End Sub
Подсчитать количество ячеек содержащая определенные слова, В листе подсчитать количество ячеек
 
WorksheetFunction.CountIf
Не сравнивает или не присваивает значение в ячейку, Не сравнивает или не присваивает значение в ячейку
 
Цитата
Дело не в данных, а в циклах похоже
Используйте Option Explicit и посмотрите какие переменные не определены
Не сравнивает или не присваивает значение в ячейку, Не сравнивает или не присваивает значение в ячейку
 
Цитата
Trim не помог
WorksheetFunction.Trim
Как перевернуть таблицу через разное количество строчек
 
Цитата
Добавила дальше часы, но ничего не обновилось
Добавьте на лист в ячейку D1 номер месяца (8), а в D2 год (2022)
присланного отчета и запустите макрос Sub RotationTable()
Код
Option Explicit

Sub RotationTable()
Dim i As Integer
Dim n As Integer
Dim iLastRow As Long
Dim iLR As Long
Dim BeginRow As Long
Dim EndRow As Long
Dim iFIO As String
Dim iDateBegin As Date
Dim FoundDate As Range
    With Application
      .ScreenUpdating = False                    'отключение обновление экрана
      .Calculation = xlCalculationManual         'отключение пересчёт формул вручную
      .DisplayAlerts = False                     'отключение предупреждающих сообщений
    End With
Dim iLastDay As Integer     'последний день месяца и года из ячеек D1 и D2
Dim iDate As Date
  Range("F1:AJ1").ClearContents
   iLastDay = Day(DateSerial(Range("D2"), Range("D1") + 1, 1) - 1)
     For i = 1 To iLastDay      'заполняем первую строку от столбца F датами
       Cells(1, 5 + i) = DateSerial(Range("D2"), Range("D1"), i)
     Next
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   Range("E2:AJ" & iLastRow).Clear
     BeginRow = 2   'строка с ФИО
   For i = BeginRow To iLastRow
        n = 0
      Do                    'ищем диапазон с данными по каждой ФИО
        n = n + 1
        EndRow = BeginRow + n
      Loop While IsDate(Cells(EndRow, "A"))
      
      iDateBegin = Format(Cells(BeginRow + 1, "A"), "dd.mm.yyyy")
        Set FoundDate = Rows(1).Find(iDateBegin, , xlFormulas, xlWhole)
        iLR = Cells(Rows.Count, "E").End(xlUp).Row + 1  'следующая строка в столбце Е
      Cells(iLR, "E") = Cells(BeginRow, "A")            'ФИО
      Range(Cells(BeginRow + 1, "B"), Cells(EndRow - 1, "B")).Copy
      Cells(iLR, FoundDate.Column).PasteSpecial xlPasteAll, Transpose:=True
      Range(Cells(iLR, FoundDate.Column), Cells(iLR, 5 + iLastDay)).HorizontalAlignment = xlCenter
      BeginRow = EndRow
      i = i + n - 1
   Next
       Range("A2").Activate
    With Application
      .ScreenUpdating = True
      .Calculation = xlCalculationAutomatic
      .DisplayAlerts = True
    End With
End Sub
Изменено: Kuzmich - 31.08.2022 12:09:45
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 266 След.
Наверх