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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 246 След.
Поиск соответствующего значения в неструктурированном массиве
 
Цитата
любым идеям по реализации
Код
Sub tt()
Dim i As Long
Dim iLastRow As Long
Dim FoundK As Range
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For i = 43 To iLastRow
    Set FoundK = Range("A3:N38").Find(Cells(i, "A"), , xlValues, xlWhole)
      Cells(i, "B") = FoundK.Offset(-2)
  Next
End Sub
Форматирование по правилу: наличие верхней и нижней границ
 
Ranker Dark,
А чем мое решение не подошло?
Копируйте код нормально и будет вам счастье.
Форматирование по правилу: наличие верхней и нижней границ
 
Код
Sub iBorders()
Dim rng As Range
  For Each rng In Range("D4:J4")
    If rng.Borders(xlEdgeTop).LineStyle = xlContinuous And rng.Borders(xlEdgeBottom).LineStyle = xlContinuous Then
      rng.Interior.ColorIndex = 8
    End If
  Next
End Sub
Макрос для поиска и подсветки ячеек в таблице из заданного диапазона (состоящего из нескольких составляющих)
 
Цитата
макрос для поиска и подсветки ячеек в таблице, например, (жёлтым цветом)
Код
Sub iArticle()
Dim iLastRow As Long
Dim i As Long
Dim Article As String
Dim FoundArticle As Range
Dim FirstAdres As String
Dim j As Integer
  iLastRow = Cells(Rows.Count, "G").End(xlUp).Row
  Range("G4:H" & iLastRow).Interior.ColorIndex = xlNone
'  iLastRow = Cells(Rows.Count, "J").End(xlUp).Row
  For i = 3 To 7
    Article = Cells(i, "J")
Set FoundArticle = Columns(7).Find(Article, , xlValues, xlWhole)
    If Not FoundArticle Is Nothing Then     'нашли
        FirstAdres = FoundArticle.Address   'адрес первого вхождения
        Do
          For j = 11 To 14
            If FoundArticle.Offset(, 1) = CStr(Cells(i, j)) Then
              FoundArticle.Resize(, 2).Interior.ColorIndex = 6
              Exit For
            End If
          Next
            Set FoundArticle = Columns(7).FindNext(FoundArticle)
        Loop While FoundArticle.Address <> FirstAdres
    End If
  Next
End Sub
Выделение изменяемого диапазона заполненніх ячеек
 
Код
Range("F5").CurrentRegion.Select
форматирование по правилу: в ячейке сверху должет быть текст и он не должен содержать определенного слова.
 
Цитата
Нужно произвести форматирование ячеек, которые удовлетворяют особому правилу:
Код
Sub Schar()
Dim rng As Range
  For Each rng In Range("D4:K5")
    If WorksheetFunction.IsText(rng) And Not rng = "Шар" Then
      rng.Offset(1).Borders(xlEdgeLeft).Weight = xlThin
    End If
  Next
End Sub
Как получить название улицы из текста, содержащего адрес?
 
Цитата
минус всего это в колонки разное положение наименование улицы
UDF
Код
Function iStreet(cell$)
 With CreateObject("VBScript.RegExp")
     .IgnoreCase = True
     .Pattern = "(ул\.|улица|пр\.)\s([^,]+)"
     If .test(cell) Then
       iStreet = .Execute(cell)(0).SubMatches(1)
     Else
       .Pattern = "([^,]+)(?=ул\.|тракт|пр\.)"
       iStreet = .Execute(cell)(0)
     End If
 End With
End Function
Заполнение таблицы данными с заведомо известным максимальным количеством строк
 
ГДВ,
Попробуйте такой вариант
Код
Sub Tablica()
Dim i As Long
Dim j As Integer
Dim n As Integer
Dim iLastRow As Long
Dim iCol As Integer              'количество необходимых столбцов
Dim k As Integer                 'кол-во столбцов с Range("P6")
Dim iLR As Long
Dim iLastCol As Integer
  iLR = Cells(Rows.Count, "A").End(xlUp).Row
  iLastCol = Cells(4, Columns.Count).End(xlToLeft).Column
    Range(Cells(4, 1), Cells(iLR, iLastCol)).ClearContents
  iLastRow = Cells(Rows.Count, "O").End(xlUp).Row
  iCol = WorksheetFunction.RoundUp((iLastRow - 5) / Range("P6"), 0)
  If iCol >= 15 Then MsgBox "При таком количестве строк данные будут затерты": Exit Sub
   For n = Range("P6") - 1 To 1 Step -1
      k = 0
    Do
      k = k + 1
    Loop While k * Range("P6") + (iCol - k) * n <> iLastRow - 5 And k < iCol
      If k * Range("P6") + (iCol - k) * n = iLastRow - 5 Then Exit For
   Next
    j = 1
  For i = 6 To k * Range("P6") + 5 Step Range("P6")
    Range(Cells(i, "O"), Cells(i + Range("P6") - 1, "O")).Copy Cells(4, j)
    j = j + 1
  Next
  For i = k * Range("P6") + 6 To iLastRow Step n
    Range(Cells(i, "O"), Cells(i + n - 1, "O")).Copy Cells(4, j)
    j = j + 1
  Next
End Sub
Заполнение таблицы данными с заведомо известным максимальным количеством строк
 
В первом приближении макрос
Код
Sub Tablica()
Dim i As Long
Dim j As Integer
Dim iLastRow As Long
Dim iCol As Integer              'количество необходимых столбцов
Dim k As Integer                 'кол-во столбцов с Range("P6")
  iLastRow = Cells(Rows.Count, "O").End(xlUp).Row
  iCol = WorksheetFunction.RoundUp((iLastRow - 5) / Range("P6"), 0)
  Range(Cells(4, 1), Cells(3 + Range("P6"), iCol)).ClearContents
    k = 0
  Do
    k = k + 1
  Loop While k * Range("P6") + (iCol - k) * (Range("P6") - 1) <> iLastRow - 5 Or k > iCol - 1
    j = 1
  For i = 6 To k * Range("P6") + 5 Step Range("P6")
    Range(Cells(i, "O"), Cells(i + Range("P6") - 1, "O")).Copy Cells(4, j)
    j = j + 1
  Next
  For i = k * Range("P6") + 6 To iLastRow - 5 Step Range("P6") - 1
    Range(Cells(i, "O"), Cells(i + Range("P6") - 2, "O")).Copy Cells(4, j)
    j = j + 1
  Next
End Sub
Подтянуть количество значений (груп товаров по регионам) из другого листа
 
При активном листе Report2 запустить макрос
Код
Sub GroupNapravlenie()
Dim iLastRow As Long
Dim Found_N As Range
Dim FAdr As String
 Application.ScreenUpdating = False
 With Worksheets("Report1")
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Range("B2:M" & iLastRow).ClearContents
  For i = 2 To iLastRow
   Set Found_N = .Columns("I").Find(Cells(i, "A"), , xlValues, xlWhole)
    If Not Found_N Is Nothing Then
      FAdr = Found_N.Address
      Do
        Select Case Found_N.Offset(, -7)
         Case "1"
           Cells(i, "B") = Cells(i, "B") + 1
         Case "3"
           Cells(i, "C") = Cells(i, "C") + 1
         Case "11"
           Cells(i, "D") = Cells(i, "D") + 1
         Case "12"
           Cells(i, "E") = Cells(i, "E") + 1
         Case "15"
           Cells(i, "F") = Cells(i, "F") + 1
         Case "18"
           Cells(i, "G") = Cells(i, "G") + 1
         Case "20"
           Cells(i, "H") = Cells(i, "H") + 1
         Case "26"
           Cells(i, "I") = Cells(i, "I") + 1
         Case "29"
           Cells(i, "J") = Cells(i, "J") + 1
         Case "30"
           Cells(i, "K") = Cells(i, "K") + 1
         Case "31"
           Cells(i, "L") = Cells(i, "L") + 1
         Case "37"
           Cells(i, "M") = Cells(i, "M") + 1
        End Select
          Set Found_N = .Columns("I").FindNext(Found_N)
      Loop While Found_N.Address <> FAdr
    End If
  Next
 End With
 Application.ScreenUpdating = True
End Sub
Как сделать цикличное копирование макросом данных в отдельный лист по условию
 
Кросс http://www.excelworld.ru/forum/10-46682-1
И примера так и нет.
Выгрузка на отдельном листе объем данных за нужную дату
 
Поставить автофильтр и выгрузить видимые
Развернуть файл из Вертикального в горизонтальный
 
Цитата
Может еще кто сможет помочь?
А мой вариант не подошел?
Удаление всех строк между двумя значениями в столбце
 
Список удаляемых номеров на Листе3
Макрос запускать при активном Лист1
Код
Sub PoiskTelefonAndDeleteRows()
Dim Found_N As Range
Dim i As Long
Dim iLR As Long
Dim Found_Itogo As Range
With Worksheets("Лист3")
 iLR = .Cells(.Rows.Count, "A").End(xlUp).Row
  For i = 1 To iLR
   Set Found_N = Columns("B").Find(.Cells(i, "A"), , xlValues, xlWhole)
    If Not Found_N Is Nothing Then
        Set Found_Itogo = Cells(Found_N.Row, "A").End(xlDown)
        Rows(Found_N.Row & ":" & Found_Itogo.Row).Delete
    End If
  Next
End With
End Sub
Удаление всех строк между двумя значениями в столбце
 
Цитата
на третьем листе в столбце А
Сделайте список номеров, а затем цикл по этим номерам
Удаление всех строк между двумя значениями в столбце
 
Цитата
что от меня требуется?
Номеров, как вы написали, будет порядка 1000. Где они будут прописаны?
Для одного номера
Код
Sub PoiskTelefon()
Dim Found_N As Range
Dim Found_Itogo As Range
Dim FAdr As String
  Set Found_N = Columns("B").Find("375291112233", , xlValues, xlWhole)
    If Not Found_N Is Nothing Then
        Set Found_Itogo = Cells(Found_N.Row, "A").End(xlDown)
        Rows(Found_N.Row & ":" & Found_Itogo.Row).Delete
    End If
End Sub
Изменено: Kuzmich - 12 янв 2021 15:31:58
Удаление всех строк между двумя значениями в столбце
 
Цитата
Есть массив номеров, нужно проверить каждый и удалить все строки между совпавшим номером телефона и фразой.
Номер один раз встречается в столбце В?
Цитата
Номеров порядка 1000, в случае необходимости могу внести их руками в массив.
Внесите несколько, как пример
Изменено: Kuzmich - 12 янв 2021 15:15:51
Удалить все символы и буквы до И.О.Фамилия, Удалить все символы и буквы до И.О.Фамилия, если количество символов меняется
 
Цитата
оставалось только И.О.Фамилия
UDF
Код
Function iFIO(cell As String) As String
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "[А-ЯЁ]\.[А-ЯЁ]\. [А-ЯЁ][а-яё]+"
     If .test(cell) Then
       iFIO = .Execute(cell)(0)
     End If
 End With
End Function
Посчитать объем детали (размеры записаны в тексте)
 
UDF
Код
Function iVolume(cell$)
 With CreateObject("VBScript.RegExp")
   .Global = True
   .IgnoreCase = True
   .Pattern = "(\d+)н?-(\d+)н?-(\d+)"
    If .test(cell) Then
     iVolume = .Execute(cell)(0).SubMatches(0) * .Execute(cell)(0).SubMatches(1) * _
               .Execute(cell)(0).SubMatches(2) * 30 / 10000
     .Pattern = "\d+(?=\s?шт)"
     If .test(cell) Then
       iVolume = iVolume * .Execute(cell)(0)
     End If
    End If
 End With
End Function
возможно ли среди чисел найти те которых нет в списке
 
А я понял так, что, например, в А1 числа 4801,4802,4803,4807,4809
Надо найти пропущенные и вывести, скажем, в В1
Код
Sub MissingNumbers()
Dim j As Long
Dim arr
Dim temp As Long
  Cells(1, 2).ClearContents
    arr = Split(Cells(1, 1).Value, ",")
    j = 0
  Do
    temp = CDbl(arr(0)) + j + 1
    If InStr(1, Cells(1, 1), CStr(temp)) = 0 Then
      Cells(1, 2) = Cells(1, 2) & temp & ", "
    End If
      j = j + 1
  Loop While temp < CDbl(arr(UBound(arr)))
    Cells(1, 2) = Left(Cells(1, 2), Len(Cells(1, 2)) - 2)
End Sub
Из назначения платежа вынуть № договора, его дату и оплаченный период
 
Цитата
надо вытащить номер и дата договора
UDF
Код
Function iNumber(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "№\s?(.+)(?= от)"
     If .Test(cell) Then
       iNumber = .Execute(cell)(0).SubMatches(0)
     Else
       iNumber = "нет"
     End If
 End With
End Function

Код
Function iDate(cell$)
 With CreateObject("VBScript.RegExp")
 Dim temp
     .Global = True
     .Pattern = "от ((\d{2}\.\d{2}\.)(\d{2,4}))"
     If .Test(cell) Then
       temp = .Execute(cell)(0).SubMatches(0)
       If Len(.Execute(cell)(0).SubMatches(2)) = 2 Then
       .Pattern = "(\d{2}\.\d{2}\.)(\d{2,4})"
         iDate = .Replace(temp, "$120$2")
       Else
         iDate = .Replace(temp, "$1$2")
       End If
     Else
       iDate = "нет"
     End If
 End With
End Function
Разделение данных на листы при количестве строк больше миллиона
 
Да еще кросс http://www.excelworld.ru/forum/10-46642-1
VBA переименование файлов, Переименовать файлы по сложному сценарию
 
UDF
Код
Function iRename(cell$) As String
 With CreateObject("VBScript.RegExp")
   .IgnoreCase = True
     .Pattern = "([а-яё_]+)(\d{2})\.(\d{2})\.?(\d{2,4})?"
     If .Execute(cell)(0).SubMatches(3) = "" Then
       iRename = .Replace(cell, "$1$2_20_син.")
     ElseIf Len(.Execute(cell)(0).SubMatches(3)) = 2 Then
       iRename = .Replace(cell, "$1$2_$3_$4")
     ElseIf Len(.Execute(cell)(0).SubMatches(3)) = 4 Then
       iRename = .Replace(cell, "$1$2_$3_$4_")
     End If
 End With
End Function
Подтянуть данные на другой лист по 3-м характеристикам
 
При активном листе Task Images запустить макрос
Код
Sub SKU_Images()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim FAdr As String
Application.ScreenUpdating = False
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   Range("G2:G" & iLastRow).ClearContents
 With Worksheets("Images Data")
  For i = 2 To iLastRow
    Set FoundCell = .Columns(1).Find(Cells(i, "B"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      Do
       If InStr(1, Replace(FoundCell.Offset(, 1), "-", " "), Replace(LCase(Cells(i, "C")), "-", " ")) > 0 And _
          InStr(1, Replace(FoundCell.Offset(, 1), "-", " "), Replace(LCase(Cells(i, "D")), "-", " ")) > 0 Then
          Cells(i, "G") = FoundCell.Offset(, 1)
          Exit Do
       End If
       Set FoundCell = .Columns(1).FindNext(FoundCell)
      Loop While FoundCell.Address <> FAdr
     End If
  Next
 End With
Application.ScreenUpdating = True
End Sub
Найти значение DOF/ и REG/ и показать их в отдельный ячейках
 
Цитата
Значение DOF/ и REG/ и показать их в отдельный ячейках
UDF
Код
Function iDOF(cell$)
 With CreateObject("VBScript.RegExp")
     .Pattern = "DOF/(\d+)"
     iDOF = .Execute(cell)(0).SubMatches(0)
 End With
End Function
Function iREG(cell$)
 With CreateObject("VBScript.RegExp")
     .Pattern = "REG/(RA)?(\d+)"
     iREG = .Execute(cell)(0).SubMatches(1)
 End With
End Function
Макрос ошибочно выборочно игнорирует копирование данных
 
Urall,
Посмотрите пример сбора данных со всех листов
На листе Остатки кнопка Сбор со всех листов
Код
Sub Sbor()
Dim Sht As Worksheet
Dim iLastRow As Long
Dim iLR As Long
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Range("A2:G" & iLastRow + 1).Clear
    For Each Sht In Worksheets
      If Sht.Name <> "Остатки" Then
        With Sht
          iLR = .Cells(.Rows.Count, "A").End(xlUp).Row
          iLastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
          .Range(.Cells(2, "A"), .Cells(iLR, "F")).Copy Cells(iLastRow, "A")
          Cells(iLastRow, "G") = Sht.Name
        End With
      End If
    Next
End Sub

Удачи!
Макрос ошибочно выборочно игнорирует копирование данных
 
Urall, написал
Цитата
Задача, как я и написал: собрать данные с нескольких магазинов с товарами и получить наглядную таблицу по остатком
Оставьте лист Остатки в вашей книге и очищайте его в начале макроса
Сделайте цикл по всем листам, кроме листа Остатки, и переносите в него нужные данные с каждого листа.
Макрос ошибочно выборочно игнорирует копирование данных
 
Urall,
И при каждом запуске в первую строку всех листов добавляется слово магазин?
Макрос ошибочно выборочно игнорирует копирование данных
 
Urall,
а вы при каждом запуске макроса создаете лист "Остатки"?
Вытащить текст после заглавной буквы
 
UDF
Код
Function iText(cell$) As String
 With CreateObject("VBScript.RegExp")
     .Pattern = "[А-ЯЁ].+"
     iText = .Execute(cell)(0)
 End With
End Function
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 246 След.
Наверх