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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 225 След.
Выделить в отдельную ячейку часть текста по маске
 
Цитата
Если находим ее больше 2 раз
В четвертой строке '0001-а-1-4-к' и '0001-а-1-4-э' куда переносить?
Задать область печати в зависимости от значения в конкретной ячейке.
 
Код
If Range("K25") = 1 Then
  ActiveSheet.PageSetup.PrintArea = Range("A1:J100").Address
Else
  ActiveSheet.PageSetup.PrintArea = Range("A5:J100").Address
End
Поиск значений и вывод их в отдельный список
 
Для вашей таблицы в столбцах J:L
Макрос в модуль листа, результат в столбце M
Срабатывает при изменении содержимого в ячейке "L2"
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("L2")) Is Nothing Then
  Application.EnableEvents = False
Dim iLastRow As Long
Dim FoundCell As Range
Dim FAdr As String
    Columns("M").ClearContents
    Set FoundCell = Columns(10).Find(Target, , xlValues, xlPart)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      Do
        iLastRow = Cells(Rows.Count, "M").End(xlUp).Row + 1
        Cells(iLastRow, "M") = Cells(FoundCell.Row, "J")
       Set FoundCell = Columns(10).FindNext(FoundCell)
      Loop While FoundCell.Address <> FAdr
     End If
 End If
  Application.EnableEvents = True
End Sub
Разбить файл на отдельные для каждой даты
 
Цитата
а нужно другое конкретное имя.
Какое?
Поиск значений и вывод их в отдельный список
 
Вы можете свой файл выложить в формате .xls, а то конвертер не открывает ваш пример
Нарастающий итог в диапазонах. Макрос.
 
Код
    If Not Intersect(Target, Range("C4:C999, E4:E999, G4:G999, I4:I999")) Is Nothing Then

Цитата
должен быть нарастающий итог
Код
Target.Offset(0, 1).Value = Target.Offset(-1, 1).Value + Target.Value
Поиск значений и вывод их в отдельный список
 
Используйте Find и FindNext  с параметром xlPart
Разбить файл на отдельные для каждой даты
 
См. https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=120814
Как открыть/закрыть книгу которая находится в одной папке с открытой книгой
 
Цитата
чтобы файл который требуется открыть находился в одной папке с инструментом?
Начальный путь указывается в
Код
.InitialFileName = ThisWorkbook.Path

Но вы в диалоговом окне можете выбрать любую папку и нужный файл, как в проводнике
Как открыть/закрыть книгу которая находится в одной папке с открытой книгой
 
Привяжите макрос к своей кнопке
Код
Sub Zajavka()
Dim FD As FileDialog
Dim iFileName As String
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .Filters.Clear  'удаляет предопределенные фильтры
        .Filters.Add "Microsoft Excel files", "*.xls*"
        .Filters.Add "All files", "*.*"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path
        .Title = "Выберите нужный файл заявки"
        .ButtonName = "Открыть"
        If .Show = False Then
            MsgBox "Вы не указали нужный файл!", 48, "Ошибка"
            Exit Sub
        Else
            iFileName = .SelectedItems(1)
        End If
    End With
    Set FD = Nothing
       'открываем выбранную книгу в режиме только чтение
      Workbooks.Open Filename:=iFileName, UpdateLinks:=False, ReadOnly:=True
      'открываемая книга становится активной
End Sub
Как открыть/закрыть книгу которая находится в одной папке с открытой книгой
 
Используйте в макросе диалог выбора файла
Код
Application.FileDialog(msoFileDialogFilePicker
Сбор определенных данных со всех листов в одной книге, тольк в определенные ячейки
 
Цитата
в таблице не очищаются эти колонки, а до записываются.
Цитата
чтоб данные собирались только с Лист1 и Лист3?
Код
Sub main()
Dim sh As Worksheet
Dim sht As Worksheet
Dim lrow&, arrfio(), arrdt()
Dim ArrList
Dim i As Integer
  ArrList = Array("Лист1", "Лист2", "Лист3")
  Set sht = ThisWorkbook.Worksheets("Сводная")
  lrow = sht.Range("A" & sht.Rows.Count).End(xlUp).Row + 1
  Range("A2:J" & lrow).ClearContents
  'For Each sh In ThisWorkbook.Worksheets     'цикл по листам
  For i = 0 To UBound(ArrList)
      Set sh = ThisWorkbook.Worksheets(ArrList(i))
    If sh.Name <> sht.Name Then
      lrow = sh.Range("b" & sh.Rows.Count).End(xlUp).Row
      arrdt = sh.Range("c2:c" & lrow).Value  'дата рождения
      arrfio = sh.Range("b2:b" & lrow).Value 'ФИО
       lrow = sht.Range("a" & sht.Rows.Count).End(xlUp).Row + 1
       sht.Range("a" & lrow).Resize(UBound(arrfio)).Value = arrfio
       sht.Range("j" & lrow).Resize(UBound(arrdt)).Value = arrdt
       Erase arrdt, arrfio
    End If
  Next
End Sub
Перевернуть таблицу и посчитать сумму
 
Katerina Larionova,
Цитата
на последнем листе "НАДО" выведено то, что я успела сделать с помощью формул
Я формулами не умею, могу помочь только с макросами.
Я так понимаю, что у вас в каждый месяц года есть два листа с данными (листы п и ш).
На них есть объединенные ячейки и вам надо их удалить и просуммировать данные за каждую дату.
А затем собрать данные со всех листов в лист "НАДО"
Если готовы работать с макросами, то можно обсудить детали. Всего доброго!
Перевернуть таблицу и посчитать сумму
 
Цитата
он больше 100 кб
Можно до 300 Кб
Список в зависимости от "галочек"
 
Пропишите для галочки связь с ячейкой
Извлечение телефонных номеров на отдельный лист по заданным маскам
 
llaih,
Цитата
Если можно с макросом
Попробуйте применить регулярные выражения, типа
Код
Function iMaska(cell$)
 With CreateObject("VBScript.RegExp")
     .Pattern = "9991{2}2{2}3{2}"
     If .test(cell) Then
       iMaska = .Execute(cell)(0)
     Else
       iMaska = ""
     End If
 End With
End Function

Маска .Pattern = "9991{2}2{2}3{2}" выделит номер 999112233
Комбинируя цифры можно создать требуемые маски
например      .Pattern = "99900002[0-9]"
Копирование данных в добавленные строки по критерию с помощью макроса
 
Grisha777999,
Цитата
Debug показывает на строчку 38
у вас в первом примере в ячейке I1 было "оттгруженно кг", а во втором просто кг
Фрагмент кода = Split(.Range("I1"), " ")(1) вытаскивал кг для первого случая.
Для второго случая напишите = .Range("I1")
Сумма чисел до сегодняшнего дня в таблице
 
Макросом, проверяйте.
Код
Sub iSumma()
Dim FoundDate As Range
Dim S1 As Double
Dim S2 As Double
Dim S3 As Double
Dim S4 As Double
  S1 = WorksheetFunction.Sum(Range("A2:G2"))
  S2 = WorksheetFunction.Sum(Range("A4:G4"))
  S3 = WorksheetFunction.Sum(Range("A6:G6"))
  S4 = WorksheetFunction.Sum(Range("A8:G8"))
  Set FoundDate = Columns("A:G").Find(Date, , xlFormulas, xlWhole)
  If Not FoundDate Is Nothing Then
    Select Case FoundDate.Row
      Case 1
        Range("A1") = WorksheetFunction.Sum(Range(Cells(2, 1), Cells(FoundDate.Row + 1, FoundDate.Column)))
      Case 3
        Range("A1") = S1 + WorksheetFunction.Sum(Range(Cells(4, 1), Cells(FoundDate.Row + 1, FoundDate.Column)))
      Case 5
        Range("A1") = S1 + S2 + WorksheetFunction.Sum(Range(Cells(6, 1), Cells(FoundDate.Row + 1, FoundDate.Column)))
      Case 7
        Range("A1") = S1 + S2 + S3 + WorksheetFunction.Sum(Range(Cells(8, 1), Cells(FoundDate.Row + 1, FoundDate.Column)))
      Case 9
        Range("A1") = S1 + S2 + S3 + S4 + WorksheetFunction.Sum(Range(Cells(8, 1), Cells(FoundDate.Row + 1, FoundDate.Column)))
    End Select
  Else
    MsgBox "В таблице нет сегодняшней даты: " & Date
  End If
End Sub
Копирование данных в добавленные строки по критерию с помощью макроса
 
Grisha777999,
Проверяйте
Скрытый текст
Проставить дату начала и окончания недели, согласно номера недели.....
 
eroshin1991,
Цитата
в ручную, пишу)
С ячейки А10 и вниз проставил даты с 01.01.2020 и до 31.12.2020
Затем запустил макрос
Код
Sub WeekNum()
Dim i As Long
Dim iLastRow As Long
Dim j As Integer
Dim FDay As Integer
Dim EDay As Integer
Dim LastDay As Integer
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   For i = 10 To iLastRow            'проставляем номер недели в столбец В
     Cells(i, "B") = CInt(Format(Cells(i, "A"), "ww", 2))
   Next
     Rows("6:7").ClearContents
     j = 2
   For i = 10 To iLastRow
      Cells(6, j) = Cells(i, "B")    'номер недели
      FDay = Day(Cells(i, "A"))      'первый день недели
      LastDay = Day(DateSerial(Year(Cells(i, "A")), Month(Cells(i, "A")) + 1, 1) - 1)
     Do
       If Cells(i + 1, "B") <> Cells(i, "B") Then Exit Do
       i = i + 1
       If Day(Cells(i, "A")) = LastDay Then Exit Do
     Loop While Cells(i + 1, "B") = Cells(i, "B")
       EDay = Day(Cells(i, "A"))     'последний день недели
       Cells(7, j) = "c " & FDay & " - " & EDay
     If Day(Cells(i, "A")) = LastDay Then j = j + 1
       j = j + 1
   Next
End Sub
Перевернуть таблицу и посчитать сумму
 
Katerina Larionova,
Цитата
в Реальности это 4 файла. в каждом 24 вкладки ( по 2 на каждый месяц)
Так приведите пример реального файла и что вы хотите получить в итоге
Перевернуть таблицу и посчитать сумму
 
Katerina Larionova,
На листе "пример" всего 16 блоков в первой строке.
Откуда на листе "итог", который получается из листа "пример" появились блоки 17-23 ?
Копирование данных в добавленные строки по критерию с помощью макроса
 
Чтоже вы Grisha777999,
были на форуме и не ответили на мои вопросы. Кому надо решить вашу проблему?
Преобразование в текст, Есть таблица, где используются промежуточные итоги, нужны вытянуть данные в текстовой файл
 
RaHHiT,
Цитата
есть таблица (Банковская выписка).
Так и приведите эту таблицу в примере Excel
Подавление сообщения
 
Код
Application.DisplayAlerts = False   
   
В конце макроса вернуть  
Код
Application.DisplayAlerts = True   
Поиск соответствующих значений
 
gukov,
Цитата
Таблицы на разных листах, естественно.
Естественно привести пример
Копирование данных в добавленные строки по критерию с помощью макроса
 
Grisha,
На листе "отчет" в колонки ЕД.измер. и Количество откуда брать значения?
В "ИТОГО принято и отгружено продукции за отчетный месяц на сумму:" вы имеете ввиду сумму по столбцу J ?
Изменено: Kuzmich - 22 Янв 2020 13:18:51
Перевернуть таблицу и посчитать сумму
 
Не быть мне волшебником  :(
Разделение текста от цифр
 
Цитата
разделить текст с цифрами
UDF
Код
Function Razdelit(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "[А-ЯЁа-яё ]+(?= \d)"
     Razdelit = .Execute(cell)(0)
 End With
End Function
Копирование данных в добавленные строки по критерию с помощью макроса
 
Grisha777999,
даты от и до перенесите в M2 (01.01.2020) и N2 (31.01.2020)
Макрос в модуль листа "отчет", срабатывает при изменении дат.
В первом приближении, надо будет еще кое-что доделать. Попробуйте сами.
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("M2:N2")) Is Nothing Then
  Application.EnableEvents = False
 Dim FirstDay As Date
 Dim EndDay As Date
 Dim iLastRow As Long
 Dim Rng As Range
 Dim n As Integer
  FirstDay = Range("M2")
     EndDay = Range("N2")
  With Worksheets("данные")
    iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    Set Rng = .Range("A1:M" & iLastRow)
      If Not .AutoFilterMode Then    'проверяем установлен Автофильтр на листе или нет
         Rng.AutoFilter              'устанавливаем автофильтр на столбцы таблицы
      Else
         If .FilterMode = True Then .ShowAllData 'если Автофильтр применён, то снимаем все фильтры
      End If
    .Range("A1:M" & iLastRow).AutoFilter Field:=4, Criteria1:= _
         ">=" & CDbl(FirstDay), Operator:=xlAnd, Criteria2:="<=" & CDbl(EndDay)
         n = .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Rows.Count
     Rows(5).Resize(n - 1).Insert
     Range("B5") = 1
     Range("B5:B" & 4 + n).DataSeries
    .AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Offset(1).Copy Range("C5")
    .AutoFilter.Range.Columns(5).SpecialCells(xlCellTypeVisible).Offset(1).Copy Range("D5")
    .AutoFilter.Range.Columns(3).SpecialCells(xlCellTypeVisible).Offset(1).Copy Range("E5")
    .AutoFilter.Range.Columns(6).SpecialCells(xlCellTypeVisible).Offset(1).Copy Range("F5")
    '
    .AutoFilter.Range.AutoFilter
  End With
End If
  Application.EnableEvents = True
End Sub
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 225 След.
Наверх