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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 211 След.
Выделение нескольких слов в ячейке другим цветом
 
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For i = 1 To iLastRow
    Cells(i, "C") = Cells(i, "A") & " " & Cells(i, "B")
    Cells(i, "C").Characters(1, Len(Cells(i, "A"))).Font.ColorIndex = 3
  Next
End Sub
Разнести показатели из текста по строкам
 
Пример создайте
Вычленение части текста из текстовой ячейки
 
Цитата
но встречаются уникальные части текста (от одного до трех слов разделенных пробелами)
Это слова, начинающиеся с большой буквы?
Копирование значений из отдельных ячеек из одной книги в другую
 
Цитата
Файл Отчёт.xlsm один и его местоположение не меняется, а вот файлов КП тьма
Но ведь одновременно у вас открыты только два файла
Код
Sub Perenos()
Dim FoundCell As Range
Dim ListВывод As Worksheet
Dim ListCRM As Worksheet
Dim TotalSum As Double
Set ListВывод = ThisWorkbook.Worksheets("Вывод")
  Set ListCRM = Workbooks("Отчет.xls").Worksheets("CRM")
  Set FoundCell = Columns("A:M").Find("Итоговая сумма предложения, включая НДС 20%", , xlValues, xlWhole)
    TotalSum = FoundCell.Offset(, 1)
    'переносите эту сумму в нужную ячейку листа ListCRM
End Sub
Копирование значений из отдельных ячеек из одной книги в другую
 
Строку с "Итоговая сумма предложения, включая НДС 20%" можно найти при помощи функции Find
Код
FoundCell = Columns("A:M").Find("Итоговая сумма предложения, включая НДС 20%", , xlValues, xlWhole)

Дату искать в столбцах "N:O"
Копирование значений из отдельных ячеек из одной книги в другую
 
Цитата
скопировать ячейки (отмеченные желтым)
Эти ячейки всегда в одних и тех же местах, или их надо искать по Заказчик, ФИО, Адрес и т.д.
Суммирование строк Стоимость Наценка Скидка, строки в разных накладных в разных местах
 
Макрос в стандартный модуль
Запускать при активном листе "Источник"
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim Cost As Double
Dim n As Long
Dim iCol As Integer
  iCol = 10 'это столбец J
 iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
  For i = 4 To iLastRow
    Cost = Cells(i, iCol)
    n = i
    Do While Cells(i + 1, "B") = "-"
      Cost = Cost + Cells(i + 1, iCol)
      i = i + 1
    Loop
    Cells(n, iCol + 1) = Cost
    Cells(n, iCol + 1).NumberFormat = "# ##0.00"
    If i = iLastRow + 1 Then Exit Sub
  Next
End Sub

Результат в столбце К. Возможно надо подготовить столбец К (очистить содержимое, снять объединение)
Суммирование строк Стоимость Наценка Скидка, строки в разных накладных в разных местах
 
Цитата
каждый день при получении накладных эти строки могут быть в разных   местах.
А столбец со стоимостью, наценкой и скидкой один и тот же?
И почему на листе "Источник" стоимость в столбце J, а на листе "Как надо" - в I  ?
Найти одинаковые ячейки и копировать соседние, Копировать пару соседних ячеек, если значения в указанных двух сравниваемых столбцах полностью совпадают
 
Кросс на http://www.excelworld.ru/
Проверка ячейки на наличие подстроки (VBA)
 
Цитата
проверить наличие этого разделителя
Используйте InStr(1, Cells(lR + i, 1), Zakr)>1
Макрос для сравнения текста в ячейке с названием всех листов в книге и создание нового листа
 
Цитата
Если листа с таким названием нет, то создать новый лист
В стандартный модуль
Код
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
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 211 След.
Наверх