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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 258 След.
Поиск и замена значения по двум соответствующим ячейкам, Поиск и замена значения через VBA
 
Макрос в модуль Лист1, при изменении ячейки J4 срабатывает и меняет значение
Код
Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("J4")) Is Nothing Then
    Application.EnableEvents = False
Dim FoundImja As Range
Dim FAdr As String
  Set FoundImja = Columns(1).Find(Range("G4"), , xlValues, xlWhole)
       If Not FoundImja Is Nothing Then
           FAdr = FoundImja.Address
         Do
           If FoundImja.Offset(, 1) = Range("H4") Then
              FoundImja.Offset(, 2) = Range("J4")
              Exit Do
           End If
           Set FoundImja = Columns(1).FindNext(FoundImja)
         Loop While FoundImja.Address <> FAdr
       End If
  End If
    Application.EnableEvents = True
End Sub
Подскажите, как можно в VBA использовать переменные в диапазоне функции Range ?
 
Yuri Kr [ Женщина ] создавая тему на другом форуме, информируйте об этом
http://www.excelworld.ru/forum/10-47757-1
Вытащить число в текстовой строке по признаку
 
UDF
Код
Function iMetr(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\d+(?=\s?(м|кв.м))"
   If .test(cell) Then
     iMetr = .Execute(cell)(0)
   Else
     iMetr = ""
   End If
 End With
End Function
Создание папки и файла, создать папку и файл при помощт Эксель
 
Роман, написал
Цитата
Как сделать что бы изменения в исходной книге сохранялись ?
Исходная книга - это ThisWorkbook
Код
ThisWorkbook.Close SaveChanges:=True
Создание папки и файла, создать папку и файл при помощт Эксель
 
Создавайте директорию в той папке, где находится ThisWorkbook
Код
Dim iPath As String
iPath = ThisWorkbook.Path & "\" & [A1].Value
   'если такой папки нет , то создаем ее
   If Dir(iPath, vbDirectory) = "" Then MkDir iPath
'создаете новую книгу, проделываете с ней манипуляции и сохраняете
ActiveWorkbook.SaveAs iPath  & "\" & [A1].Value & ".xls"
Изменено: Kuzmich - 19.06.2021 19:54:25
Регулярные выражения. Метасимволы. Поиск наиболее полного руководства
 
Фридл Дж. Регулярные выражения. Библиотека программиста.
Бен Форта Освой самостоятельно регулярные выражения (regexp).
Ян Гойвертс, Стивен Левитан Регулярные выражения. Сборник рецептов
Преобразование шахматки в линии
 
Код
Sub iConversion()
Dim i As Long
Dim iLastRow As Long
Dim j As Integer
 iLastRow = 19
    For i = 3 To 16
      For j = 2 To 10
        If Cells(i, j) <> "" Then
          Cells(iLastRow, "A") = Cells(i, "A")
          Cells(iLastRow, "B") = Cells(2, j)
          Cells(iLastRow, "C") = Cells(i, j)
          iLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
        End If
      Next
    Next
End Sub
Макрос для удаления строк в умной таблице
 
Елена М,
Смотрим
https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=121301
Вставка информации из соседней ячейки по 1-му условию (Если, то, иначе), Примеры имеются, ГОСТ/ГОСТ
 
UDF
Код
Function iGost(cell$)
 With CreateObject("VBScript.RegExp")
     .Pattern = "(ГОСТ|ОЖО|ОСТ|ТУ).+"
   If .test(cell) Then
     iGost = .Execute(cell)(0)
   Else
     iGost = ""
   End If
 End With
End Function
Как в коде VBA записать название диапазона, в котором неизвестен адрес строки
 
Цитата
диапазон меняется в зависимости от количества вставленных строк.
Код
Sub Poisk_kromka()
Dim i As Long
Dim Found_kromka As Range
Dim Found_Itogo As Range
Dim FRow As Long
Dim ERow As Long
  Set Found_kromka = Columns("D").Find("Кромка", , xlValues, xlWhole)
    If Not Found_kromka Is Nothing Then
        FRow = Found_kromka.Row + 1
        Set Found_Itogo = Columns("B").Find("Упаковка", Found_kromka.Offset(, -2), xlValues, xlWhole)
          ERow = Found_Itogo.Row - 1
            'определили строки начала и конца диапазона и делаем цикл
            For i = FRow To ERow
              If Cells(i, "D") = "" Then
                Cells(i, "D") = "без кромки"
              End If
            Next
    End If
End Sub
Автоматическое заполнение ячеек одного столбца в зависимости от значений в ячейках другого столбца.
 
Цитата
какой ресурс, книгу и так далее порекомендуете изучать
Посмотрите https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=77616
Автоматическое заполнение ячеек одного столбца в зависимости от значений в ячейках другого столбца.
 
Цитата
в ячейке соседствующей с ячейкой содержащей подобные знаки
Почитайте, что такое UDF, приложите файл пример.
UDF в стандартный модуль, в ячейку =iCellR6(A1) и протащить вниз.
Автоматическое заполнение ячеек одного столбца в зависимости от значений в ячейках другого столбца.
 
Цитата
чтобы в ячейке соседствующей с ячейкой содержащей подобные знаки авт-ски проставлялось значение "Пальчиковые элементы питания"
UDF
Код
Function iCellR6(cell$)
 With CreateObject("VBScript.RegExp")
     .Pattern = "\b[LR]+6(/316)?\b"
   If .test(cell) Then
'     iCellR6 = .Execute(cell)(0)
     iCellR6 = "Пальчиковые элементы питания"
   Else
     iCellR6 = ""
   End If
 End With
End Function
Как разделить крайнюю ячейку по горизонтали и выполнить сдвиг вниз с копированием строки?
 
Код
Sub Razdel_FIO()
Dim i As Long
Dim iLastRow As Long
Dim n As Integer
Dim arr
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   For i = iLastRow To 1 Step -1
     If InStr(1, Cells(i, "D"), Chr(10)) <> 0 Then
       arr = Split(Cells(i, "D"), Chr(10))
       For n = UBound(arr) To 0 Step -1
         If arr(n) <> "" Then
           Rows(i + 1).Insert
           Cells(i + 1, "D") = arr(n)
           Range("A" & i & ":C" & i).Copy Range("A" & i + 1)
         End If
       Next
         Rows(i).Delete
     End If
   Next
End Sub
Подсчет количества ячеек по определенным месяцам из общего массива значений
 
Цитата
формулы почему-то считают все на "0"
Попробуйте макросом
Код
Sub Tablica()
Dim i As Long
Dim j As Long
Dim iLastRow As Long
Dim iLR As Long
Application.ScreenUpdating = False
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
 iLR = Cells(Rows.Count, "C").End(xlUp).Row
 Range("D2:D" & iLR).ClearContents
 For j = 2 To iLR
  For i = 2 To iLastRow
    If Val(Split(Cells(i, "A"), ".")(1)) = Month(Cells(j, "C")) And _
        Val(Split(Cells(i, "A"), ".")(2)) = Year(Cells(j, "C")) Then
       Cells(j, "D") = Cells(j, "D") + Cells(i, "B")
    End If
  Next
 Next
Application.ScreenUpdating = True
End Sub
Вытащить фрагменты из текста с разделителями /
 
Я формулами не умею
Макрос
Код
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 = "[^/]+"
  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 + 3) = CDbl(mo(n))
      Next
    End If
  Next
End With
End Sub
Поиск нескольких совпадений и вставка значений на другой лист
 
Цитата
как теперь это сделать, когда номеров строк несколько?
При активном листе Расчет запустить макрос, для двух столбцов
Код
Sub primer1()
Dim myPhrase As String, myCell As Range
Dim cell_row As Long
Dim iLR As Long
Dim Obraz As Range
Dim FAdr As String
Dim Result As Worksheet
  Set Result = ThisWorkbook.Worksheets("Результат")
  With Result
    .Cells.Clear
    myPhrase = "Нормативное значение"
  Set Obraz = Columns("F:G").Find("Образец №", , xlValues, xlPart)
    Set myCell = Columns("B:E").Find(myPhrase, Obraz.Offset(, -4), xlValues, xlWhole)
    Set myCell = Obraz.Offset(1, -4)
     If Not myCell Is Nothing Then
       FAdr = Obraz.Address
       Do
         cell_row = myCell.Row
         'в зависимости от Образца переносим данные на лист Результат
         iLR = .Cells(.Rows.Count, "D").End(xlUp).Row + 2
         .Cells(iLR, "D") = Obraz                   'Образец №
         .Range(.Cells(iLR, "D"), .Cells(iLR + 1, "D")).Merge
         .Cells(iLR, "D").HorizontalAlignment = xlCenter
         .Cells(iLR, "D").VerticalAlignment = xlCenter
         .Range(.Cells(iLR, "D"), .Cells(iLR + 1, "D")).Borders.Weight = xlThin

         .Cells(iLR, "E") = Cells(cell_row, "F")    'из столбца F листа Расчет в столбец Е Результата
         .Range(.Cells(iLR, "E"), .Cells(iLR + 1, "E")).Merge
         .Cells(iLR, "E").VerticalAlignment = xlCenter
         .Range(.Cells(iLR, "E"), .Cells(iLR + 1, "E")).Borders.Weight = xlThin
         .Cells(iLR, "E").NumberFormat = "0.000"
         
         .Cells(iLR, "F") = Cells(cell_row, "G")    'из столбца G листа Расчет в столбец F Результата
         .Range(.Cells(iLR, "F"), .Cells(iLR + 1, "F")).Merge
         .Cells(iLR, "F").VerticalAlignment = xlCenter
         .Range(.Cells(iLR, "F"), .Cells(iLR + 1, "F")).Borders.Weight = xlThin
         .Cells(iLR, "F").NumberFormat = "0.000"
         
         Set Obraz = Columns("F:G").Find("Образец №", Obraz, xlValues, xlPart)
         Set myCell = Columns("B:E").Find(myPhrase, Obraz.Offset(, -3), xlValues, xlWhole)
       Loop While Obraz.Address <> FAdr
     End If
  End With
End Sub
Преобразовать данные в большом количестве ячеек за раз
 
Цитата
Как можно в один клик преобразовать все эти данные?
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 3).End(xlUp).Row
  For i = 3 To iLastRow
    Cells(i, "D") = CDate(Cells(i, "C"))
  Next
End Sub
Необходимо прописать текстовое значение в ячейках, по нескольким условиям, и только для видимых ячеек
 
Код
"...D.SpecialCells(xlCellTypeVisible)..."

это все видимые строки столбца D, а вам нужна конкретная строка x.Row
Поиск нескольких совпадений и вставка значений на другой лист
 
Цитата
как теперь вывести нужные ячейки
Для этого на листе Результат надо найти последнюю ячейку и в нее перенести данные по соответствующему образцу
Необходимо прописать текстовое значение в ячейках, по нескольким условиям, и только для видимых ячеек
 
Код
Sub Test()
    Dim x As Range
    Dim C  As Range
    Dim D  As Range
ActiveSheet.Rows("1:1").AutoFilter Field:=2, Criteria1:="Хорошие записи"
    Set C = Range("C2:C" & Cells(Rows.Count, "A").End(xlUp).Row)
    Set D = Range("D2:D" & Cells(Rows.Count, "A").End(xlUp).Row)
    For Each x In C.SpecialCells(xlCellTypeVisible)
        If x.Value = 0 Then
          Cells(x.Row, "D") = "жен"
        ElseIf x.Value = 1 Then
          Cells(x.Row, "D") = "муж"
        ElseIf x.Value <> 1 And x.Value <> 2 Then
          MsgBox "Не верный ИД пола в строке " & x.Row
       End If
    Next x
End Sub
Поиск нескольких совпадений и вставка значений на другой лист
 
Цитата
макрос находит только первое совпадение словосочетания "Нормативное значение", а мне нужно, чтобы он сделал это для всех образцов, чтобы получить номера этих строк
Код
Sub primer1()
Dim myPhrase As String, myCell As Range
Dim FAdr As String
Dim Result As Worksheet
  Set Result = ThisWorkbook.Worksheets("Результат")
  With Result
    myPhrase = "Нормативное значение"
    Set myCell = Range("A2:AC52").Find(myPhrase)
     If Not myCell Is Nothing Then
       FAdr = myCell.Address
       Do
         'в зависимости от Образца переносим данные на лист Результат
       
         Set myCell = Range("A2:AC52").FindNext(myCell)
       Loop While myCell.Address <> FAdr
     End If
  End With
End Sub

myCell.Address показывает адреса строк, где найдено  "Нормативное значение"
Поиск нескольких совпадений и вставка значений на другой лист
 
Цитата
а мне нужно, чтобы он сделал это для всех образцов
И для каждого образца данные берутся из разных столбцов листа Расчет?
Зачем нужно объединение ячеек на листе Результат?
Поиск нескольких совпадений и вставка значений на другой лист
 
antisept,
Цитата
а мне нужно на лист "Результат"
Почему на листе Результат для Образец №3 три значения берутся из листа Расчет строка 26, а два значения из строки 21 ?
Изменено: Kuzmich - 05.06.2021 15:29:33
Поиск значений по нескольким условиям (одно выбирается списком), данные не цифровые
 
Цитата
при выборе из списка (ячейка "K2") номера
Макрос в модуль листа
Код
Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("K2")) Is Nothing Then
     Application.EnableEvents = False
    Range("D2:G" & Cells(Rows.Count, "D").End(xlUp).Row).AdvancedFilter xlFilterCopy, _
                      CopyToRange:=Range("K2")
  End If
    Application.EnableEvents = True
End Sub
Сортировка отдельных диапазонов, разделенных пустой ячейкой
 
alexey loginov, написал
Цитата
выдаётся ошибка 1004
Где-то после 7-ой строки у вас есть объединенные ячейки.
В вашем приведенном примере макрос работает
Сортировка отдельных диапазонов, разделенных пустой ячейкой
 
Как написал Mershik,
Цитата
убрать фильтры, для листа исх.
Код
Sub SortRng()
Dim rng As Range
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "I").End(xlUp).Row
  For Each rng In Range("I7:I" & iLastRow).SpecialCells(2, 1).Areas
    If rng.Count > 1 Then
     Range(rng.Cells(1, -7), rng.Cells(rng.Count)).Sort key1:=rng.Cells(1), Order1:=xlAscending
    End If
  Next
End Sub
Сбор данных с разных книг с сохранением истории
 
Miko, А дубль темы зачем?
https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=140779&TITLE_SEO=140779-makros-konsolidatsii-dannykh-v-odnom-svodnom-liste&logout_butt=%D0%92%D1%8B%D0%B9%D1%82%D0%B8

дубль-тема закрыта и будет удалена [МОДЕРАТОР]

Зачем переносить данные в цикле по столбцам? Почему нельзя сразу диапазоном?
Код
Sub Консолидация_()
    Dim ws As Worksheet, sh As Worksheet, i As Long
    Application.ScreenUpdating = False: Set sh = Sheets("Итого")
    For Each ws In Sheets
      If ws.Name <> sh.Name Then
         i = sh.Cells(Rows.Count, 3).End(xlUp).Row + 1: If i < 3 Then i = 3
         iLR = ws.Cells(1, "A").End(xlDown).Row
         ws.Range(ws.Cells(3, "A"), ws.Cells(iLR, "R")).Copy sh.Cells(i, "B")
      End If
    Next
End Sub
Макрос консолидации данных в одном сводном листе
 
Miko,
Зачем переносить данные в цикле по столбцам? Почему нельзя сразу диапазоном?
Код
Sub Консолидация_()
    Dim ws As Worksheet, sh As Worksheet, i As Long
    Application.ScreenUpdating = False: Set sh = Sheets("Итого")
    For Each ws In Sheets
      If ws.Name <> sh.Name Then
         i = sh.Cells(Rows.Count, 3).End(xlUp).Row + 1: If i < 3 Then i = 3
         iLR = ws.Cells(1, "A").End(xlDown).Row
         ws.Range(ws.Cells(3, "A"), ws.Cells(iLR, "R")).Copy sh.Cells(i, "B")
      End If
    Next
End Sub
Макрос для создания сводной таблицы
 
cargo9,
Цитата
только помогите кто-нибудь плиз
Вот посмотрите пример выполнения макроса
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 258 След.
Наверх