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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 211 След.
Макрос для сравнения текста в ячейке с названием всех листов в книге и создание нового листа
 
Цитата
Если листа с таким названием нет, то создать новый лист
В стандартный модуль
Код
Sub CreateSheet()
Dim iShtName As String
Dim iLastRow As Long
Dim Blank As Worksheet
   Set Blank = ThisWorkbook.Worksheets("Бланк для печати")
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
 iShtName = Range("A1")
  If Not SheetExist(iShtName) Then  'функция проверки наличия листа в файле
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = iShtName
    Blank.Range("A1:E" & iLastRow).Copy
    Range("A1").PasteSpecial xlPasteColumnWidths
    Range("A1").PasteSpecial
      Range("E1") = Range("E1")
    Blank.Activate
    Range("A1").Select
  Else
    'это если такой лист есть
  End If
End Sub

    'функция проверки наличия листа в файле, лист есть - true
Код
Function SheetExist(iName As String) As Boolean
    On Error Resume Next
    With Worksheets(iName): End With
    SheetExist = (Err = 0)
End Function

Ветку, если такой лист есть, доделайте сами
Копирование значений в ячейках несколько раз по условию
 
Код
Sub FIO()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
 Range("A4:A" & iLastRow).ClearContents
  For i = 5 To 11
     iLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
    Cells(iLastRow, "A").Resize(Range("E4")) = Cells(i, "H")
  Next
End Sub
Маркировка Фильтра, Маркировка Фильтра
 
Так вроде синим цветом выделяются ярлычки столбцов с фильтром
Перестановка значений в ячейках по заданному порядку
 
10  9  6  8  порядок 2  3  4  1 должно получится  9  6  8  10 , а в примере 9  8  6  10 ?
Сортировка в каждом блоке группировки
 
Находим границы диапазонов
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim iBegin As Long
Dim iEnd As Long
    iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    iBegin = 14
  For i = 14 To iLastRow
      iEnd = iBegin
    Do While Cells(iEnd + 1, "B").IndentLevel = 1 And iEnd <= iLastRow
      iEnd = iEnd + 1
    Loop
    'определили iBegin и iEnd (14-28,30-33,35-38,40-45 , в этом диапазоне делаем сортировку
    'сортировка по столбцу G
    '......................
    iBegin = iEnd + 2
    i = iEnd + 1
  Next
End Sub
сложный фильтр vba с копированием массива, фильтр по одной колонки зная значение в другой
 
Цитата
какой функции можно определить значение в ячейке A?
У вас в коде есть поиск значения модели
Код
Set rFound = .Find(What:=strName, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= False)

Если нашли rFound - это объект типа Range, то марка будет в Cells(rFound.Row, "A")
или через Offset
Сортировка в каждом блоке группировки
 
Цитата
подскажите как сделать это макросом.
Делаете цикл по столбцу В, в котором есть артикулы с жирным шрифтом (отступ=0) и
с обычным шрифтом (отступ=1). По этим признакам можно определить границы диапазона,
в котором делать сортировку
сложный фильтр vba с копированием массива, фильтр по одной колонки зная значение в другой
 
Модель Lancer вы ищете в столбце В листа 2.
Зачем тогда в коде цикл по всем листам?
Нашли модель, тогда в этой же строке в столбце А будет марка.
Сделать автофильтр по марке и перенести видимые строки на лист 1
сложный фильтр vba с копированием массива, фильтр по одной колонки зная значение в другой
 
А это смотрели https://www.planetaexcel.ru/techniques/1/38/
Перенос наименования столбца в ячейки
 
Код
If Len(arr(r, c)) Then arr(r, c) = txtHead & ": " & arr(r, c) & ";"
Поиск цифровых значений в ячейке, Поиск цифрового значения в ячейке при определенных условиях
 
Код
Function iDigits(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "\d+(\,?\d+)?[-+/ ]?(\d+(\,?\d+)?)? ?(?=шт|г|кг|гр|gr|разніе)"
     If InStr(cell, "розмірний ряд") > 1 Then
       iDigits = .Execute(Split(LCase(cell), "розмірний ряд")(1))(0)
     ElseIf InStr(cell, "штука") > 1 Then
       iDigits = .Execute(Split(LCase(cell), "штука")(1))(0)
    End If
 End With
End Function
Поиск цифровых значений в ячейке, Поиск цифрового значения в ячейке при определенных условиях
 
Цитата
4тутт оже разніе сим1561651волі штука +1,0КГ  разніе е5щ345345е символі  
А выделить надо 1,0КГ
Какие еще будут размерности?
Поиск цифровых значений в ячейке, Поиск цифрового значения в ячейке при определенных условиях
 
Цитата
искало например " штука"
Покажите конкретную строку
Сортировка в каждом блоке группировки
 
Цитата
Подскажите как сделать сортировку разом в каждом блоке
Макросом определяем границы каждой группы по отступу=1 и сортируем найденный диапазон
Добавление символа после определенных значений.
 
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim iDoza As Integer
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "№\d+$"
  For i = 2 To iLastRow
    If .Test(Cells(i, "A")) Then
      iDoza = Mid(Cells(i, "A"), .Execute(Cells(i, "A"))(0).FirstIndex + 2)
      Cells(i, "A") = Left(Cells(i, "A"), .Execute(Cells(i, "A"))(0).FirstIndex + 1) & iDoza * 10
    End If
  Next
 End With
End Sub
Разбивка данных ячеек по стобцам.
 
Цитата
данные из ячеек столбца А были разделены по разным столбцам
Как вытащить наименование придумайте сами
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Range("C2:G" & iLastRow).ClearContents
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
  For i = 2 To iLastRow
    If InStr(1, Cells(i, "A"), "Клубная цена:") > 1 And _
       InStr(1, Cells(i, "A"), "По акции:") = 0 Then
      .Pattern = "Клубная цена:\d+p"
      Cells(i, "C") = .Execute(Cells(i, "A"))(0)
    End If
    If InStr(1, Cells(i, "A"), "Обычная цена:") > 1 And _
       InStr(1, Cells(i, "A"), "По акции:") = 0 Then
      .Pattern = "Обычная цена:\d+p"
      Cells(i, "D") = .Execute(Cells(i, "A"))(0)
    End If
    If InStr(1, Cells(i, "A"), "Обычная цена:") > 1 And _
       InStr(1, Cells(i, "A"), "По акции:") > 1 Then
      .Pattern = "По акции: \d+p"
      Cells(i, "E") = .Execute(Cells(i, "A"))(0)
      .Pattern = "Обычная цена:\d+p"
      Cells(i, "F") = .Execute(Cells(i, "A"))(0)
    End If
    If InStr(1, Cells(i, "A"), "Клубная цена:") = 0 And _
       InStr(1, Cells(i, "A"), "Обычная цена:") = 0 And _
       InStr(1, Cells(i, "A"), "По акции:") = 0 Then
      .Pattern = "\d+p"
      Cells(i, "G") = .Execute(Cells(i, "A"))(0)
    End If
  Next
 End With
End Sub
Изменено: Kuzmich - 17 Окт 2019 15:08:14
Поиск цифровых значений в ячейке, Поиск цифрового значения в ячейке при определенных условиях
 
Razdva, Попробуйте так
Код
Sub iDigits_()
Dim i As Long
Dim iLastRow As Long
Dim iString As String
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
    Range("C1:C" & iLastRow).ClearContents
  For i = 1 To iLastRow
    .Pattern = "\d+(\,?\d+)?[-+/ ](\d+(\,?\d+)?)?"
    iString = Split(LCase(Cells(i, "A")), "розмірний ряд")(1)
    If .Test(iString) Then
      Cells(i, "C") = .Execute(iString)(0)
    Else
      .Pattern = "\d+(\,?\d+)? ?(?=кг|гр|gr|разніе)"
      If .Test(iString) Then
        Cells(i, "C") = .Execute(iString)(0)
      End If
    End If
  Next
 End With
End Sub

Или UDF
Код
Function iDigits(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "\d+(\,?\d+)?[-+/ ]?(\d+(\,?\d+)?)? ?(?=шт|г|кг|гр|gr|разніе)"
     iDigits = .Execute(Split(LCase(cell), "розмірний ряд")(1))(0)
 End With
End Function
Изменено: Kuzmich - 17 Окт 2019 13:48:57
Поиск цифровых значений в ячейке, Поиск цифрового значения в ячейке при определенных условиях
 
Цитата
Варианты:
(new word) 350gr+ , -200гр/шт , :+0,5КГ , +1,0КГ , 250гр+- ,
Включите все возможные варианты в пример
Вывести список номеров товаров, где есть примечания, вывести список по отношению к нумерации товаров по столбцу G
 
В строке
Код
x = x & cell.Offset(1, 1) & ", "

в переменной x записываются номера через запятую с пробелом
В строке
Код
x = Left(x, Len(x) - 2)

убирается последняя запятая с пробелом
Отделить численного виражения физической величины от ед.изм
 
UDF для значения и размерности
Код
Function Znachenie(cell$)
 With CreateObject("VBScript.RegExp")
  .Global = True
  .IgnoreCase = True
  .Pattern = "\d[mGO]"
     Znachenie = Left(cell, .Execute(cell)(0).FirstIndex + 1)
 End With
End Function


Код
Function Razmernost(cell$)
 With CreateObject("VBScript.RegExp")
  .Global = True
  .IgnoreCase = True
  .Pattern = "\d[mGO]"
     Razmernost = Mid(cell, .Execute(cell)(0).FirstIndex + 2)
 End With
End Function
VBA: копирование и вставка данных с листа на лист
 
Цитата
не будут совпадать названия столбцов, можно ли что-то придумать
Добавьте в таблицы по строчке и сделайте свою шапку, но чтобы названия совпадали
Подстановка данных в таблицу с разным порядком столбцов, Как подставить данные из одной таблицы в другую
 
Посмотрите https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=121779&TITLE_SEO=121779-vba-kopirovanie-i-vstavka-dannykh-s-lista-na-list&logout_butt=%D0%92%D1%8B%D0%B9%D1%82%D0%B8
VBA: копирование и вставка данных с листа на лист
 
При активном Листе1 запустить макрос
Код
Sub Perenos()
  With Worksheets("Лист2")
    .Rows("3:" & Rows.Count).Clear
    Range("B2:H19").AdvancedFilter xlFilterCopy, , .Range("B2:E2")
  End With
End Sub
Поиск цифровых значений в ячейке, Поиск цифрового значения в ячейке при определенных условиях
 
Добавьте в паттерн
Код
.Pattern = "\d+(\,?\d+)?[-+/](\d+(\,?\d+)?)?"
Поиск цифровых значений в ячейке, Поиск цифрового значения в ячейке при определенных условиях
 
Код надо поместить в стандартный модуль, а не в модуль листа
Поиск цифровых значений в ячейке, Поиск цифрового значения в ячейке при определенных условиях
 
Приложите пример с вставленным макросом
Вывести список номеров товаров, где есть примечания, вывести список по отношению к нумерации товаров по столбцу G
 
Надо переделывать цикл по cell
Поиск цифровых значений в ячейке, Поиск цифрового значения в ячейке при определенных условиях
 
Функцию в стандартный модуль, а в ячейке (например B1) пишите =iDigits(A1) и протягиваете вниз
Вывести список номеров товаров, где есть примечания, вывести список по отношению к нумерации товаров по столбцу G
 
Цитата
если напротив пусто в G, то спускаемся вниз до первой непустой ячейки, тогда будет четко номер товара.
Во-первых у вас там не пусто, а пробел
Во-вторых тогда получится в x
"1, 5, 5, 20, 20, 20, 20, "
Вывести список номеров товаров, где есть примечания, вывести список по отношению к нумерации товаров по столбцу G
 
Код
x = x & Cells(cell.Row, "G") & ", "
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 211 След.
Наверх