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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 233 След.
VBA - поиск всех значений по заданному условию и обновление связанных данных, FindNext в цикле ошибка
 
Цитата
в части продолжения поиска через FindNext
Метод FindNext не работает, если перед этим был поиск Find для другого аргумента
Нужно произвести поиск
Код
Set pInvoice = .Rows(rFndShipNr.Row).Find(rInvoice, pInvoice)

И переменные определить как Range
Код
Dim rPayDate As Date, rPayWeek As Range, pInvoice As Range

И остальные переменные приведите в соответствие
Перемещение строки на другой лист по условию, Помогите прикрутить макрос по переносу строк в списке задач по статусу "завершено"
 
trainee, написал
Цитата
Расшифруйте пожалуйста синтаксис этой строчки,
Код
Range("B" & i & ":J" & i).Copy
   
Для i=4 это Range("B4:J4").Copy и этот диапазон копируется на лист Sheets("Завершенные")
Можно использовать конструкцию типа
Код
Range(Cells(i, "B"), Cells(i, "J")).Copy
Перемещение строки на другой лист по условию, Помогите прикрутить макрос по переносу строк в списке задач по статусу "завершено"
 
trainee,
Вы копируете диапазон
Код
Range("B" & CStr(i) & ":J" & i).Copy 

в
Код
Sheets("Завершенные").Range("B" & lr)

при этом переменную lr не изменяете и у вас все копируется в одну строку
После удаления строки
Код
Rows(i).Delete

добавьте
Код
lr=lr + 1
Перемещение строки на другой лист по условию, Помогите прикрутить макрос по переносу строк в списке задач по статусу "завершено"
 
trainee,
Что-то я сомневаюсь в правильной работе макроса.
Цикл надо делать от последней строки до 4 с шагом -1
Код
For i =  Cells(Rows.Count, 4).End(xlUp).Row To 4 Step -1
Копирование части таблицы основываясь на цвете заливки ячеек
 
Цитата
копирует все данные предыдущего дня изменяет дату заполнения
Макрос в стандартный модуль
Код
Sub iCopyDiapazon()
Dim Sht As Worksheet
Dim iLastRow As Long
Dim FoundData As Range
  For Each Sht In Worksheets
    With Sht
      iLastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
      'ищем ячейку с последней датой (слово Дата)в столбце А
      Set FoundData = .Columns(1).Find("Дата", .Range("A1"), xlValues, xlWhole, xlByRows, xlPrevious)
      .Range("A" & FoundData.Row & ":H" & iLastRow).Copy .Cells(iLastRow + 1, 1)
       .Cells(iLastRow + 2, 1) = .Cells(FoundData.Row + 1, 1) + 1
    End With
  Next
End Sub
Удаление одинаковых пар в двух столбцах
 
Вот теперь нормально. Всего доброго!
Удаление одинаковых пар в двух столбцах
 
Nordheim,
И количество по вашему варианту не совпадает, например
Сыр Печенье 2     а д.б. 8
Удаление одинаковых пар в двух столбцах
 
Nordheim,
Цитата
If arr(i, 1) > arr(i, 2) Then
А что в массивах можно СЫР сравнивать с ПЕЧЕНЬЕМ ?
Как это происходит?
Удаление одинаковых пар в двух столбцах
 
aleksa_yara,
Еще попробуйте вариант
Код
Sub UniqPara()
Dim i As Long
Dim iLastRow As Long
Dim dic As Object
 iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    Set dic = CreateObject("scripting.dictionary"): dic.comparemode = 1
  For i = 2 To iLastRow
    dic.Item(CStr(Cells(i, "A").Value & "_" & Cells(i, "B").Value)) = _
    dic.Item(CStr(Cells(i, "A").Value & "_" & Cells(i, "B").Value)) + Cells(i, "C") 'сумма в dic.items
  Next
  For i = 2 To iLastRow
    dic.Item(CStr(Cells(i, "A").Value & "_" & Cells(i, "B").Value)) = _
    dic.Item(CStr(Cells(i, "A").Value & "_" & Cells(i, "B").Value)) + _
    dic.Item(CStr(Cells(i, "B").Value & "_" & Cells(i, "A").Value))
    dic.Remove CStr(Cells(i, "B").Value & "_" & Cells(i, "A").Value)
  Next
  [D2].Resize(dic.Count, 2) = Application.Transpose(Array(dic.keys, dic.items))
End Sub

Удачи!
Выделение блоков одинаковых значений, Выделение двумя цветами блоков рядом стоящих повторяющихся значений в строке
 
А макрос в стандартном модуле?
Удаление одинаковых пар в двух столбцах
 
aleksa_yara, написала
Цитата
если есть вариант сделать так - было бы даже лучше
Проверьте такой вариант
Код
Sub DelDubl()
Dim i As Long
Dim iLastRow As Long
Dim Para As String
Dim ParaRev As String
Dim FoundPoz As Range
Dim iRow As Long
Dim FAdr As String
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 2 To iLastRow - 1         'проверяем есть ли дубликаты Para и ParaRev
    Para = Cells(i, 1)
    ParaRev = Cells(i, 2)
    Set FoundPoz = Range("A" & i & ":A" & iLastRow).Find(Para, , xlValues, xlWhole)
    If Not FoundPoz Is Nothing Then 'нашли Para после Cells(i, 1)
      FAdr = Cells(i, 1).Address
      If Not FoundPoz.Address = FAdr Then    'есть ли еще Para в столбце А
       Do
        If FoundPoz.Offset(, 1) = ParaRev Then
         Cells(i, 3) = Cells(i, 3) + FoundPoz.Offset(, 2)   'есди дубликат, то суммируем кол-во
         Range("A" & FoundPoz.Row & ":C" & FoundPoz.Row).Delete
         iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
        End If
        Set FoundPoz = Range("A" & i & ":A" & iLastRow).FindNext(FoundPoz)
       Loop While FoundPoz.Address <> FAdr
      End If
    End If
  Next
  For i = 2 To iLastRow - 1     'проверяем есть ли дубликаты ParaRev и Para
    Para = Cells(i, 1)
    ParaRev = Cells(i, 2)
    Set FoundPoz = Range("A" & i & ":A" & iLastRow).Find(ParaRev, , xlValues, xlWhole)
    If Not FoundPoz Is Nothing Then
      FAdr = Cells(i, 1).Address
      If Not FoundPoz.Address = FAdr Then    'есть ли еще ParaRev в столбце А
       Do
        If FoundPoz.Offset(, 1) = Para Then
         iRow = FoundPoz.Row
         Cells(i, 3) = Cells(i, 3) + FoundPoz.Offset(, 2)  'есди обратн. дубликат, то суммируем кол-во
         Range("A" & FoundPoz.Row & ":C" & FoundPoz.Row).Delete
         iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
        End If
          If iRow = iLastRow + 1 Then Exit Do
        Set FoundPoz = Range("A" & i & ":A" & iLastRow).Find(ParaRev, , xlValues, xlWhole)
       Loop While Not FoundPoz Is Nothing
      End If
    End If
  Next
End Sub
Выделение блоков одинаковых значений, Выделение двумя цветами блоков рядом стоящих повторяющихся значений в строке
 
Цитата
но не сработало
Что при этом на экране при запуске макроса?
Выделение блоков одинаковых значений, Выделение двумя цветами блоков рядом стоящих повторяющихся значений в строке
 
Попробуйте макрос
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim j As Integer
Dim n As Integer
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Range("B2:M" & iLastRow).Interior.ColorIndex = xlNone
  For i = 2 To iLastRow
    For j = 2 To 13
        n = 0
      Do
        n = n + 1
      Loop While Cells(i, j + n) = Cells(i, j)
            If n >= 3 Then Range(Cells(i, j), Cells(i, j + n - 1)).Interior.ColorIndex = n
        j = j + n - 1
    Next
  Next
End Sub
Изменено: Kuzmich - 25 Мар 2020 18:59:13
Удаление одинаковых пар в двух столбцах
 
Цитата
есть сочетание соль - молоко в количестве 4 сочетания и молоко - соль в количестве 4 сочетания
Что оставить сочетание соль - молоко в количестве 8 ?
Настроить перенос данных на 2 страницу начиная с определенной строки таблицы
 
Цитата
переход обязательно начинался с последней строки с услугой(выделена желтым)
Макросом ищете строку с "Всего к оплате" и перед ней вставляете горизонтальный разрыв
Автоматическое заполнение наряда-задания при выборе определенной даты и номера бригады
 
Код
'в модуль листа НАРЯД
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Union(Range("L1"), Range("Q4"))) Is Nothing Then
  Application.EnableEvents = False
Dim iDate As Range
Dim FAdr As String
Dim n As Integer
  With Worksheets("ОБЩАЯ")
   Range("B8:Q10").ClearContents
   Range("B4:B6").ClearContents
   Set iDate = .Columns(1).Find(Range("L1"), , xlValues, xlWhole)
   If Not iDate Is Nothing Then
    FAdr = iDate.Address
     n = 8
    Do
      If iDate.Offset(, 3) = Range("Q4") Then   'проверка бригады
        Cells(n - 4, "B") = iDate.Offset(, 4)   'наименование работ
        Cells(n, "B") = iDate.Offset(, 2)        'ФИО
        Cells(n, "Q") = Range("Q4")             'номер бригады
      End If
        If iDate.Offset(, 3) = Range("Q4") Then n = n + 1
      Set iDate = .Columns(1).FindNext(iDate)
    Loop While iDate.Address <> FAdr
   End If
  End With
 End If
  Application.EnableEvents = True
End Sub

Срабатывает при изменении ячеек L1 и Q4
Макрос расширенного фильтра. Диапазон условий и таблица - на разных листах
 
Цитата
Диапазон условий и таблица - на разных листах
В примере от Николая Павлова создайте лист Результат и при активном
листе Лист1 запустите макрос
Код
Sub Макрос1()
  With Sheets("Результат")
    Range("B7").Copy .Range("K1")   'наименование     критерий фильтрации
    .Range("K2") = "Лук"                  'Лук                     на листе Результат
    Range("A7").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=.Range("K1:K2"), CopyToRange:=.Range("A1:I1"), Unique:=False
    .Range("K1:K2").Clear
  End With
End Sub

На лист Результат будут перенесены строки с критерием фильтрации "Лук".
Удачи!
Автоматическое заполнение наряда-задания при выборе определенной даты и номера бригады
 
Тема: Автоматическое заполнение наряда-задания при выборе определенной даты и номера бригады.
На 23.03.2020 бригада №1 выполняет два вида работ: Шпатлевка стен и Укладка ламината.
Что должно быть отражено в наряде в ячейке В4 ?
Замена конкретного формата денежный, поиск и замена импортированных форматов
 
В коде из сообщения #8 замените
Код
c.NumberFormat = "#,##0.00"
на
Код
c.NumberFormat = "General"
Преобразование таблицыАртикул/Инвойс в Артикул/Инвойсы
 
Код
'запускать при активном листе Преобразованная табл
Sub iArticul_Invoice()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim FAdr As String
Dim j As Integer
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   Range("B2:G" & iLastRow).ClearContents
 With Worksheets("Исходная табл")
  For i = 2 To iLastRow
     j = 2
    Set FoundCell = .Columns(1).Find(Cells(i, 1), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      Do
         Cells(i, j) = .Cells(FoundCell.Row, 2)
         Set FoundCell = .Columns(1).FindNext(FoundCell)
         j = j + 1
      Loop While FoundCell.Address <> FAdr
     End If
  Next
 End With
End Sub
Замена конкретного формата денежный, поиск и замена импортированных форматов
 
Александр Чекирда,
Да это код VBA
Попробуйте для столбца С
Код
Sub iConv()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 2 To iLastRow
   If Cells(i, 3).NumberFormat = "#,##0.00 [$€-407];[Red]#,##0.00 [$€-407]" Then
      Cells(i, 3).NumberFormat = "#,##0.00"
   End If
  Next
End Sub
Замена конкретного формата денежный, поиск и замена импортированных форматов
 
Цитата
Как найти и выделить в диапазоне ячейки с форматом "денежный" (€ немецкий Германия)?
Код
If Selection.NumberFormat = "#,##0.00 [$€-407];[Red]#,##0.00 [$€-407]" Then
Преобразование формул в значение, но с условем
 
Цитата
по условию выделения ячеек.
Не по условию выделения, а в диапазоне Range("E6:DH53")
Поиск последней ячейки в таблице, содержащей дату
 
Код
Sub iLR_D()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Columns("D").Find("*", Range("D1"), xlValues, xlWhole, xlByColumns, xlPrevious).Row
   i = iLastRow
 Do While Not IsDate(Cells(i, "D"))
   i = i - 1
 Loop
   iLastRow = i
   Cells(i, "D").Select
End Sub
Распределение информации из строк в списке по листам в определенную ячейку
 
VladimirTavr,
У вас в файле куча листов, вам уже говорили, что надо смотреть в первых девяти листах
Транспорирование таблицы построчно с помощью PQ
 
У кого нет PQ, макрос
Код
Sub iConvert()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
 iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
   Range("J4:L20").ClearContents
  For i = 4 To iLastRow
     iLR = Cells(Rows.Count, 10).End(xlUp).Row + 1
    Range("C3:G3").Copy
    Cells(iLR, 10).PasteSpecial xlPasteValues, Transpose:=True
    Cells(iLR, 11).Resize(5) = Range("B" & i)
    Range("C" & i & ":G" & i).Copy
    Cells(iLR, 12).PasteSpecial xlPasteValues, Transpose:=True
  Next
End Sub
Вставка разрывов страниц по условию
 
Цитата
чтобы на одной страничке было только 23 строки.
Код
Sub ВставитьРазрыв()   
Dim i As Long
Dim iLastRow As Long
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  ActiveSheet.ResetAllPageBreaks
    i = 24
 Do While i < iLastRow
    ActiveSheet.HPageBreaks.Add ActiveSheet.Range("A" & i)
    i = i + 23
 Loop
End Sub
Изменено: Kuzmich - 20 Мар 2020 14:58:53
выбор определенных значений со смещением с разных листов
 
Код
Sub Poisk()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Range("C3:C" & iLastRow).ClearContents
  For i = 3 To iLastRow
    If Not IsEmpty(Cells(i, "A")) Then
     If SheetExist(Cells(i, "B")) Then
      With Worksheets(Cells(i, 2).Text)
       Set FoundCell = .Columns("B").Find(Cells(i, "A"), , xlValues, xlWhole)
        If Not FoundCell Is Nothing Then
          Cells(i, "C") = .Cells(FoundCell.Row, "C")
        End If
      End With
     End If
    End If
  Next
End Sub
Function SheetExist(iName As String) As Boolean
    On Error Resume Next
    With Worksheets(iName): End With
    SheetExist = (Err = 0)
End Function
Изменено: Kuzmich - 19 Мар 2020 15:02:28
Сбор-сортировка одинаковых\разных данных из разных или одной таблицы
 
Цитата
как это сделать!
Собирать суммы по коду артикула макросом
Код
Sub test()
Dim dicObj As Object
Dim i&
Set dicObj = CreateObject("scripting.dictionary")
  Columns("H:I").ClearContents
  For i = 7 To Cells(Rows.Count, "A").End(xlUp).Row
    If Not IsEmpty(Cells(i, "A")) Then
     dicObj.Item(Cells(i, "A").Text) = dicObj.Item(Cells(i, "A").Text) + Cells(i, "F")
    End If
  Next i
    Range("H7").Resize(dicObj.Count) = Application.Transpose(dicObj.keys)    'уникальные из столбца А
    Range("I7").Resize(dicObj.Count) = Application.Transpose(dicObj.Items)   'сумма по столбцу F по уникальным
End Sub
Автоматическое выделение значения в таблице при поиске
 
Цитата
Как осуществить?
Приложить пример.
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 233 След.
Наверх