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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 268 След.
Заполнение умной таблицы данными из этой же таблицы по условию
 
Цитата
как написать код)
Попробуйте так
Код
Sub insertrow()
Dim tbl As ListObject
Dim n As Long
Dim k As Long
Dim i As Long
  Set tbl = ActiveSheet.ListObjects(1)
  For n = tbl.DataBodyRange.Rows.Count To 1 Step -1
    k = tbl.DataBodyRange(n, 5)
    For i = 1 To k - 1
      tbl.ListRows.Add (n + i)
      tbl.DataBodyRange(n + i, 1) = tbl.DataBodyRange(n, 1) + i
      tbl.DataBodyRange(n + i, 2) = tbl.DataBodyRange(n, 2)
      tbl.DataBodyRange(n + i, 3) = tbl.DataBodyRange(n, 3)
      tbl.DataBodyRange(n + i, 4) = tbl.DataBodyRange(n, 4) / k
      tbl.DataBodyRange(n + i, 4).NumberFormat = "#,###.00"
    Next
      tbl.DataBodyRange(n, 4) = tbl.DataBodyRange(n + 1, 4)
      tbl.DataBodyRange(n, 4).NumberFormat = "#,###.0"
  Next n

End Sub
Сбор данных в одну таблицу из разных листов, если поля не совпадают, т.е. поле вес может быть в разных столбцах и строках
 
Цитата
собрать данные в одну таблицу из разных листов одной книги
При активном листе сборка запустить макрос
Код
Sub Sbor()
Dim FoundPart As Range
Dim WSH As Worksheet
Dim iLastRow As Long
Dim iLR As Long
    iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
        If iLastRow <> 1 Then Range("A2:E" & iLastRow).ClearContents
    For Each WSH In Worksheets  'цикл по всем листам книги
        If WSH.Name <> "сборка" Then
With WSH
Set FoundPart = .Rows(1).Find("партия", , xlValues, xlWhole)
    If Not FoundPart Is Nothing Then
      iLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
      iLR = .Cells(.Rows.Count, 2).End(xlUp).Row
      Cells(iLastRow, 1).Resize(iLR - 2) = .Name
      .Range("A3:B" & iLR).Copy Cells(iLastRow, 2)
      FoundPart.Offset(2).Resize(5, 2).Copy Cells(iLastRow, 4)
    End If
End With
        End If
    Next WSH
End Sub
Задать адрес ячейки в виде переменных номера столбца и номера ячейки
 
Цитата
когда писать этот Range
https://vremya-ne-zhdet.ru/vba-excel/soderzhaniye-rubriki/#Obekt_Range_v_VBA_Excel
Полностью удалить слово из ячейки, если в нем содержится символ
 
Цитата
удалить слово из ячейки, если в нем содержится символ
UDF
Код
Function iResult(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .ignorecase = True
     .Pattern = "[А-ЯЁ]+©"
   If .test(cell) Then
     iResult = .Replace(cell, "")
   Else
     iResult = cell
   End If
 End With
End Function
Изменено: Kuzmich - 13.03.2024 13:53:40
Работа с одинаковыми строками
 
Цитата
По макросу пока  не смог придумать код.
Код
Sub PoiskFIO_Date()
Dim j As Long
Dim iLastRow As Long
Dim Found_Name As Range
Dim FAdr As String
Dim iDateMax As Date
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   Range("D2:E" & iLastRow).ClearContents
   Range("A1:A" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("D1"), Unique:=True
   iLastRow = Range("D2").End(xlDown).Row
 For j = 2 To iLastRow
   Set Found_Name = Columns("A").Find(Cells(j, "D"), , xlValues, xlWhole)
    If Not Found_Name Is Nothing Then
      FAdr = Found_Name.Address
     iDateMax = Found_Name.Offset(, 1)
      Do
        Set Found_Name = Columns("A").FindNext(Found_Name)
          If Found_Name.Offset(, 1) > iDateMax Then
            iDateMax = Found_Name.Offset(, 1)
          End If
      Loop While Found_Name.Address <> FAdr
          Cells(j, 5) = iDateMax
     End If
 Next
End Sub
Расцепить данные в ячейки по столбцам или вычленить нужную информацию, Необходимо расцепить данные в ячейки по столбцам или вычленить нужную информацию
 
Цитата
нужна лишь одна - Статья затрат
Код
Sub iTitle()
Dim i As Long
Dim iLastRow As Long
Dim arr
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   For i = 3 To iLastRow
     If InStr(1, Cells(i, "A"), Chr(10)) <> 0 Then
       arr = Split(Cells(i, "A"), Chr(10))
           Cells(i, "B") = arr(UBound(arr))
     End If
   Next
End Sub
Как заменить текст в ячейке, если этот текст содержит определенные значения?, Есть столбец с текстом, нужно проверить: если в тексте содержится определенный "кусок" известного текста, то заменить его только на этот "кусок".
 
Тема Вытянуть из столбца А уникальные  адреса электронной почты
Код
Sub UniqMail()
Dim arr
Dim dic As Object
Dim i As Long
Dim iLastRow As Long
Dim iMail As String
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "<(.+)>"
      iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
     Range("D2:D" & iLastRow).ClearContents
     Set dic = CreateObject("Scripting.Dictionary"): dic.comparemode = 1
     arr = Range("A2:A" & iLastRow).Value
  For i = 1 To UBound(arr)
    If .test(arr(i, 1)) Then
      iMail = .Execute(arr(i, 1))(0).submatches(0)
      dic.Item(iMail) = dic.Item(iMail) + 1
    End If
  Next i
   Range("D2").Resize(dic.Count, 2) = Application.Transpose(Array(dic.keys, dic.Items))
 End With
End Sub

Уникальные адреса электронной почты в столбце D , в столбце E их количество
В строках 13 и 14 электронные адреса не обрамлены <> и поэтому не подсчитаны
Вытащить числа (+1 символ до пробела)
 
UDF
Код
Function iDigits(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\d+[А-Я]?"
     If .Test(cell) Then
       iDigits = .Execute(cell)(0)
       If IsNumeric(iDigits) Then
         iDigits = CDbl(iDigits)
       End If
     Else
       iDigits = ""
     End If
 End With
End Function
Как отделить текст и цифры друг от друга пробелом
 
Цитата
можно макросом.
Попробуйте так
Код
Sub DigitLetter()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
With CreateObject("VBScript.RegExp")
  .Global = True
  .Pattern = "(\d+)"
  For i = 1 To iLastRow
    If .Test(Cells(i, 1)) Then
      Cells(i, 2) = WorksheetFunction.Trim(.Replace(Cells(i, 1), " $& "))
    End If
  Next
End With
End Sub
Ошибка #ЗНАЧ! в пользовательской функции, Ошибка #ЗНАЧ! в пользовательской функции
 
Цитата
количество отступов перед текстом в соседней ячейке.
Для 8-ой строки, как пример
Код
Sub iLevel()
  Cells(8, 7) = Cells(8, 6).IndentLevel
End Sub
Вставка строк по значению из ячейки, VBA
 
Цитата
Вот так решил вопрос
А формулы в столбцах вы вручную будете протягивать?
Вывод значения из текста после определенных символов
 
Цитата
как вывести значения из текста после определенных символов
Как пример
Для количества комнат
UDF
Код
Function iNumberRoom(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .MultiLine = True
     .Pattern = "Количество комнат: (.+)$"
   If .test(cell) Then
     iNumberRoom = .Execute(cell)(0).SubMatches(0)
   Else
     iNumberRoom = ""
   End If
 End With
End Function

Для площади
Код
Function iSquare(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .MultiLine = True
     .Pattern = "Общая площадь: (.+)$"
   If .test(cell) Then
     iSquare = .Execute(cell)(0).SubMatches(0)
   Else
     iSquare = ""
   End If
 End With
End Function
Макрос для вырезания по маске, Требуется помощь по макросу
 
Цитата
встречаются кадастровые номера с 3мя последними цифрами
Код
 .Pattern = "\d{2}:\d{2}:\d{7}:\d{3,4}"
Макрос для вырезания по маске, Требуется помощь по макросу
 
Цитата
требуется с колонки "Т" вытащить кадастровый номер
UDF
Код
Function iKN(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\d{2}:\d{2}:\d{7}:\d{4}"
   If .test(cell) Then
     iKN = .Execute(cell)(0)
   Else
     iKN = ""
   End If
 End With
End Function
Извлечение слов из ячейки
 
Цитата
нужно извлечь.
UDF
Код
Function iLitr(cell$)
 iLitr = Split(cell, Chr(10))(1)
End Function
Как из текста в ячейке выбрать значения, соответствующее определенным параметрам
 
Цитата
Необходимо вытащить из ячеек текст/значения
Код
Sub GetFragment()
Dim mo As Object
Dim n As Integer
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
With CreateObject("VBScript.RegExp")
  .Global = True
  .Pattern = "[A-D]{4}[0-9]{7}"
  For i = 1 To iLastRow
    If .Test(Cells(i, 1)) Then
      Set mo = .Execute(Cells(i, 1))
      For n = 0 To mo.Count - 1
        Cells(i, n + 2) = mo(n)
      Next
    End If
  Next
End With
End Sub
Список уникальных значений для старых версий
 
Цитата
Список уникальных значений для старых версий
Используйте
Код
AdvancedFilter
Просуммировать первые 30 и 100 значений в одном и том же столбце в 300 разных файлах
 
Цитата
попыталась поменять в макросе, но выдает ошибку 432
У вас в названиях файлов после года стоит нечитаемый пробел, уберите во всех файлах
Просуммировать числа столбца и вставить сумму в соседнем столбце
 
Цитата
для всех товаров из списка в строку с артикулом вставить:
Код
Sub iSumma()
Dim Rng As Range
  For Each Rng In Range("G2:G" & Cells(Rows.Count, "G").End(xlUp).Row).SpecialCells(2, 1).Areas
    Rng.Cells(1, 3) = WorksheetFunction.Sum(Rng)
    Rng.Cells(1, 4) = WorksheetFunction.Sum(Rng.Offset(, 1)) + Rng.Offset(, 1).Cells(Rng.Count + 1, 1)
  Next
End Sub
Выделить из текста определенные значения
 
UDF
Код
Function iLitr(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .ignorecase = True
     .Pattern = "\b\d+(ML|L)\b"
   If .test(cell) Then
     iLitr = .Execute(cell)(0)
   Else
     iLitr = ""
   End If
 End With
End Function
Переместить макросом первый столбец таблицы в правый край таблицы
 
karlson7, для примера2
Код
Sub Macros1()
With ActiveSheet
  .Range("A1:A" & .Cells(.Rows.Count, 2).End(xlUp).Row).Copy .Cells(1, .Cells(1, .Columns.Count).End(xlToLeft).Column + 1)
   .Columns(1).Delete
End With
End Sub
Переместить макросом первый столбец таблицы в правый край таблицы
 
Код
Sub Macros1()
With Active Sheet
  .Range("A3:A" & .Cells(.Rows.Count,2).End(xlUp).Row).Cut
  .Cells(3, .Cells(3, .Columns.Count).End(xlToLeft).Column + 1).Select 
   .Paste
   .Column(1).Delete
End With
End Sub
Excel 2003: Данные - Фильтр - Автофильтр. Как найти несколько слов?
 
Цитата
как найти в списке несколько фамилий, напр. Иванов, Петров, Сидоров?
Расширенный фильтр позволяет решить вашу задачу без всяких формул и макросов
Исходный список в столбце А
Условия выбора в столбце B
Результат в столбце D
подсчитать количество уникальных дат с наличием пустых строк по условию
 
Цитата
Помогите подсчитать количество уникальных дат в столбце А, по документам в которых присутствует "*VD*".
Код
Sub test()
Dim arr
Dim dic As Object
Dim i As Long
Dim iLastRow As Long
  Range("G1") = "Уникальные даты"
  Range("H1") = "Количество ун.дат"
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
     Range("G2:H" & iLastRow).ClearContents
     Set dic = CreateObject("Scripting.Dictionary"): dic.comparemode = 1
     arr = Range("A7:B" & iLastRow).Value
  For i = 1 To UBound(arr)
    If InStr(1, arr(i, 2), "VD") <> 0 Then
      dic.Item(arr(i, 1)) = dic.Item(arr(i, 1)) + 1
    End If
  Next i
   Range("G2").Resize(dic.Count, 2) = Application.Transpose(Array(dic.keys, dic.Items))
End Sub
Перенос значений по условию на другой Лист
 
А где
Код
Application.ScreenUpdating =True
Управление разрывами страниц
 
Цитата
После табличной части, есть строка "Итого по накладной". Я хочу завязаться на эту надпись.
Код
Sub Wstavka()
Dim Kol_voStrok As Integer
Dim StrokaWsego As Integer
Dim Wsego As Object
  'число строк на первом листе активной страницы
  Kol_voStrok = ActiveSheet.HPageBreaks(1).Location.Row - 1
  Set Wsego = ActiveSheet.Columns("F:L").Find("Всего по накладной :  ", , xlValues, xlWhole)
  StrokaWsego = Wsego.Row   'строка с Всего по накладной :
      'дальше проверяйте условие StrokaWsego больше или меньше Kol_voStrok и добавляйте разрыв
      'добавляет горизонтальный разрыв над ячейкой iCell
      'ActiveSheet.HPageBreaks.Add iCell

End Sub
Извлечь данные из ячейки
 
Цитата
пытался через регулярные выражения
Попыток не видно
Код
Sub Get_C_PC()
Dim mo As Object
Dim n As Integer
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Range("B3:C" & iLastRow).ClearContents
With CreateObject("VBScript.RegExp")
  .Global = True
  .Pattern = "[^,]+"
  For i = 3 To iLastRow
    If .Test(Cells(i, 1)) Then
      Set mo = .Execute(Cells(i, 1))
      For n = 0 To mo.Count - 1
        If Left((mo(n)), 1) = "C" Then
          Cells(i, 2) = Cells(i, 2) & mo(n) & ","
        Else
          Cells(i, 3) = Cells(i, 3) & mo(n) & ","
        End If
      Next
    End If
  Next
End With
End Sub
Несколько условий на поиск строки и выделение её цветом (vba)
 
Цитата
чтобы он искал по двум критериям
Добавить в код
Код
    If cell Is Nothing Then
        MsgBox "Ничего не найдено", vbCritical
    Else
      If cell.Offset(, 1) = Val(y) Then
        Range("A" & cell.Row & ":D" & cell.Row).Interior.ColorIndex = 6
      End If
    End If
Подсчет групп ячеек находящихся рядом и содержащих данные, Подсчет групп ячеек находящихся рядом и содержащих данные
 
Цитата
почему не работает?
В вашем примере область данных начиналась с 6-ой строки, а на рисунке там шапка таблицы.
Измените цикл For i = 7
Подсчет групп ячеек находящихся рядом и содержащих данные, Подсчет групп ячеек находящихся рядом и содержащих данные
 
Цитата
нужно чтобы в колонке AA суммировались
Код
Sub iCount()
Dim i As Long
Dim n As Integer
  For i = 6 To 23
'    n = Range("B7:Y7").SpecialCells(xlCellTypeConstants, xlNumbers).Areas.Count    'для 7 строки
   If WorksheetFunction.CountA(Range("B" & i & ":Y" & i)) <> 0 Then
     Cells(i, "AA") = Range("B" & i & ":Y" & i).SpecialCells(xlCellTypeConstants, xlNumbers).Areas.Count
   End If
  Next
End Sub
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 268 След.
Наверх