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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 258 След.
Как в коде 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,
Цитата
только помогите кто-нибудь плиз
Вот посмотрите пример выполнения макроса
Макрос для создания сводной таблицы
 
cargo9,
Поскольку
Цитата
Честно говоря, больше на ТЗ похоже   ;)
и вашего решения нет вообще, то
решение с нуля за вас
Макрос для создания сводной таблицы
 
Цитата
благодарность на человеческом языке
Как говорил Жванецкий:
Лучше маленький доллар, чем большое спасибо
Макрос для создания сводной таблицы
 
cargo9,
А что такое
Цитата
отправить донат за работу)))
Вставить значения из вертикальных диапазонов горизонтально, но так, чтобы вставка в одну строку повторялась только в в пределах одного товара
 
Mershik,
Надо бы предварительно очистить область, куда будет вывод результата
И не все переменные в макросе определены
макрос: суммирования строк по названию столбца, макрос: суммирования строк по названию столбца
 
Код
Sub iSymma()
Dim i As Long
Dim iLastRow As Long
Dim Col1 As Integer
Dim Col2 As Integer
Dim Col3 As Integer
   Col1 = Rows(1).Find("Apple", , xlValues, xlWhole).Column
   Col2 = Rows(1).Find("Pineapple", , xlValues, xlWhole).Column
   Col3 = Rows(1).Find("result", , xlValues, xlWhole).Column
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   Range(Cells(2, Col3), Cells(iLastRow, Col3 + 1)).ClearContents
  For i = 2 To iLastRow
    Cells(i, Col3).Formula = Cells(i, Col1).Address(0, 0) & "+" & Cells(i, Col2).Address(0, 0) & " ="
    Cells(i, Col3 + 1) = Cells(i, Col1) + Cells(i, Col2)
  Next
End Sub

Формула в столбце result, сама сумма правее
Изменено: Kuzmich - 24.05.2021 22:05:17
макрос: суммирования строк по названию столбца, макрос: суммирования строк по названию столбца
 
Цитата
или все таки написать за Вас?
Код
Sub iSymma()
Dim i As Long
Dim iLastRow As Long
Dim Col1 As Integer
Dim Col2 As Integer
   Col1 = Rows(1).Find("Apple", , xlValues, xlWhole).Column
   Col2 = Rows(1).Find("Pineapple", , xlValues, xlWhole).Column
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   Range("E2:E" & iLastRow).ClearContents
  For i = 2 To iLastRow
    Cells(i, 5) = Cells(i, Col1) + Cells(i, Col2)
  Next
End Sub
Макрос копирования листа с созданием гиперссылки на копию
 
Цитата
Лист 2 кнопкой планируется копировать много раз.
Я бы перед копированием проверял наличие листа с таким именем
Вставить значения из вертикальных диапазонов горизонтально, но так, чтобы вставка в одну строку повторялась только в в пределах одного товара
 
Максим Николаевич, написал
Цитата
что не так я сделал?
У вас в первоначальном варианте на каждый идентификатор приходилось четко по 9 характеристик,
а в последнем уже наблюдается чехарда
Вставить значения из вертикальных диапазонов горизонтально, но так, чтобы вставка в одну строку повторялась только в в пределах одного товара
 
При активном листе Что есть запустить макрос (добавьте сами недостающие строки вместо и т.д.)
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim KDB As Worksheet
  Set KDB = ThisWorkbook.Worksheets("Как должно быть")
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 With KDB
   For i = 2 To iLastRow Step 9
     iLR = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
     .Cells(iLR, 1) = Cells(i, 1)               'идентификатор
     .Cells(iLR, 2) = Cells(i, 2)               'рабочее напряжение
     .Cells(iLR, 4) = Cells(i, 4)               '250 V
     .Cells(iLR, 5) = Cells(i + 1, 2)           'Макс.рабочее напряжение
     .Cells(iLR, 7) = Cells(i + 1, 4)           '250 V
     'и т.д.
   Next
 End With
End Sub
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 258 След.
Наверх