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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 223 След.
Присвоить значение переменной
 
Нет ответа на вопрос, вот макрос
Код
Sub iSumma()
Dim FRow As Integer
Dim ERow As Integer
Dim FoundCell As Range
Dim FAdr As String
    Set FoundCell = Columns(20).Find("т/год", , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
        FAdr = FoundCell.Address
      Do
        FRow = FoundCell.Row + 1
        ERow = Cells(FRow, "T").End(xlDown).Row
        Cells(ERow + 1, "U") = "Сумма по т/год:"
        Cells(ERow + 1, "U").HorizontalAlignment = xlRight
        Cells(ERow + 1, "V") = WorksheetFunction.Sum(Range("T" & FRow & ":T" & ERow))
        Cells(ERow + 1, "V").NumberFormat = "#,##0.000"
        Cells(ERow + 1, "V").HorizontalAlignment = xlLeft
          Set FoundCell = Columns(20).Find("т/год", After:=FoundCell)
      Loop While FoundCell.Address <> FAdr
     End If
End Sub

Присвоить значение переменной
 
Цитата
Нужно значения т/год просуммировать
Куда выводить сумму и сколько знаков после запятой?
Присвоить значение переменной
 
Цитата
Надеюсь ясно выразился)
А где пример?
Подсветить повторы в столбце по двум условиям
 
Огласите, пожалуйста, весь список документов. Повторы идут друг за другом или могут быть в разных местах?
Группировка числовых значений в Excel
 
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim n As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    n = 1
  For i = 1 To iLastRow
    Cells(i, 2) = n
    If i / (10 * n) = 1 Then n = n + 1
  Next
End Sub
Отображать в ячейках диапазона формулы
 
maria_gug,
Метод Find возвращает объект Range, у которого можно выделить и строку, и столбец.
При дате типа 01.01.2019 в методе Find использую LookIn=xlFormulas,
т.к. при LookIn=xlValues метод Find выдает Nothing. Почему - не знаю.
Поиск ячейки с нужным значением, выбранным из раскрывающегося списка, и переход к ней
 
Цитата
Поставила в модуль листа.
Макрос надо в модуль листа Лист1
При
Код
MsgBox "Неведомая дичь " & Target.Value, vbInformation

выход из программы
Отображать в ячейках диапазона формулы
 
maria_gug,
Желательно придерживаться одной размерности отображения месяцев,
сделайте на вкладках Гвс и Гвс_Одн строку с месяцами как и на вкладке "объемные величины" 01.01.2019 и т.д.
Попробуйте такой макрос, запускать при активном листе "объемные величины"
Код
Sub iSumma()
Dim i As Long
Dim iLastRow As Long
Dim j As Integer
Dim n As Integer
Dim FoundCell As Range
Dim FoundMonth As Range
Dim Tarif As Double
Dim ArrList
Application.ScreenUpdating = False
   ArrList = Array("ГВС", "ГВС ОДН")
   iLastRow = Cells(Rows.Count, "F").End(xlUp).Row
   Range("G2:R" & iLastRow).ClearContents    'очищаем область данных
  For j = 7 To 18                                           'цикл по месяцам
    For i = 2 To iLastRow                                'цикл по лицевым счетам
      If Month(Cells(1, j)) < 7 Then
        Tarif = 3000
      Else
        Tarif = 3200
      End If
     For n = 0 To UBound(ArrList)                  'цикл по листам
      With Worksheets(ArrList(n))
       Set FoundCell = .Columns(6).Find(Cells(i, "F"), , xlValues, xlWhole)
       If Not FoundCell Is Nothing Then
         Set FoundMonth = .Rows(1).Find(Cells(1, j), , xlFormulas, xlWhole)
          Cells(i, j) = Cells(i, j) + .Cells(FoundCell.Row, FoundMonth.Column)
       End If
      End With
     Next
      Cells(i, j) = Cells(i, j) / Tarif
    Next
  Next
Application.ScreenUpdating = True
End Sub

Затем посмотрим как сделать с формулами или вы сами это сделаете.
Удачи!
Поиск ячейки с нужным значением, выбранным из раскрывающегося списка, и переход к ней
 
Этот макрос надо поместить в модуль листа, срабатывает на изменение ячейки А1
Поиск и вывод данных согласно заданному критерию
 
Цитата
адреса этих строк на разных листах могут быть разными.
Можно расширить диапазон поиска (Range("B36:M1000")), запускать макрос на каждом листе или
сделать цикл по листам
Код
Sub Rasxod_2019()
Dim i As Integer
  For i = 8 To 19
    Cells(i, "H") = Range("B36:M1000").Find(Cells(i, "B"), , xlValues, xlPart).Offset(2, 1)
  Next
End Sub
Отображать в ячейках диапазона формулы
 
maria_gug,
На вкладках Гвс и Гвс_Одн в столбце F № лицевого счета встречается один раз?
На вкладке ГВС в ячейке Н1 видимо должен быть месяц январь?
Почему все лицевые счета 9-ти значные, а два счета 0 и 1 (ячейки F2 и F66) ?
Зачем в ячейки прописывать формулы, если значения можно прописать макросом?
Правильно ли я понимаю, что до "01.07.2019" применяется Тариф1=3000, а после 3200 ?
Зачем в файле вкладка "отопление" ?
Получить курс валют от выбранной даты.
 
Цитата
Нужна формула
Я формулами не умею.
Макрос в модуль листа. Срабатывает при изменении даты и названия валюты
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("G1:G2")) Is Nothing Then
    Application.EnableEvents = False
 Dim iDate As Range
   Set iDate = Columns(1).Find(Range("G1"), , xlValues, xlWhole)
   If Not iDate Is Nothing Then
     If Range("G2") = "USD" Then
       Range("G3") = iDate.Offset(, 1)
     Else
       Range("G3") = iDate.Offset(, 2)
     End If
   Else
     MsgBox "В таблице нет даты: " & Range("G1")
   End If
 End If
   Application.EnableEvents = True
End Sub
Изменено: Kuzmich - 18 Янв 2020 21:37:56
Поиск и вывод данных согласно заданному критерию
 
Цитата
другими вариантами
Для расходов 2019 года
Код
Sub Rasxod_2019()
Dim i As Integer
  For i = 8 To 19
    Cells(i, "H") = Range("B39:M62").Find(Cells(i, "B"), , xlValues, xlPart).Offset(2, 1)
  Next
End Sub
Составление шаблона под определенную маску регулярными выражениями
 
Цитата
под шаблон Крайнова С.В.
под шаблон Крайнова С.
Код
.Pattern = "[А-ЯЁ][а-яё]+ [А-ЯЁ]\.([А-ЯЁ]\.)?"
Вытащить часть текста из таблицы
 
UDF
Код
Function iDevice(cell$)
 With CreateObject("VBScript.RegExp")
     .Pattern = "Device: (.+)(?=: S)"
     iDevice = .Execute(cell)(0).Submatches(0)
 End With
End Function
Разбиение (разделение) данных по отделам на несколько листов
 
Код
Swod.Range(Swod.Cells(FoundNomer.Row, "A"), Swod.Cells(FoundNomer.Row, "K")).Copy Cells(iLR,"A")
Разбиение (разделение) данных по отделам на несколько листов
 
В макросе нашли FoundNomer
Строка  от A до К будет Swod.Range(Swod.Cells(FoundNomer.Row, "A"), Swod.Cells(FoundNomer.Row, "K"))
Вот этот диапазон и копируйте
Разбиение (разделение) данных по отделам на несколько листов
 
Цитата
нужно всю строку копировать
Всю строку с листа "свод"?
Разбиение (разделение) данных по отделам на несколько листов
 
Макрос в стандартный модуль, запускать при активном листе "кто"
Листы по отделам создаются в процессе работы макроса
Код
'при активном листе кто
Sub Razbienie()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundNomer As Range
Dim j As Integer
Dim Swod As Worksheet
Dim Kto As Worksheet
  Set Swod = ThisWorkbook.Worksheets("свод")
  Set Kto = ThisWorkbook.Worksheets("кто")
  For j = 1 To 8     'цикл по строке с отделами
   iLastRow = Cells(Rows.Count, j).End(xlUp).Row
     'создаем новый лист
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    With Worksheets(Worksheets.Count)
      .Name = Kto.Cells(1, j)  'название листа с именем отдела
      For i = 2 To iLastRow - 1  'цикл по строкам
        Set FoundNomer = Swod.Columns(2).Find(Kto.Cells(i, j), , xlValues, xlWhole)
        If Not FoundNomer Is Nothing Then
          iLR = Cells(Rows.Count, 1).End(xlUp).Row + 1
          Cells(iLR, 1) = FoundNomer.Offset(, -1)  'дата
          Cells(iLR, 1).NumberFormat = "dd.mm.yyyy"
          Cells(iLR, 2) = FoundNomer               'номер
        End If
      Next
    End With
    Kto.Activate
  Next
End Sub
Разбиение (разделение) данных по отделам на несколько листов
 
Цитата
на 8 листов с соответствующим названием отдела.
Вы бы привели пример одного листа, что на нем должно быть
Убрать отступы между строк в одной ячейке сохраняя их последовательность.
 
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim j As Integer
Dim arr
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Range("B1:B" & iLastRow).ClearContents
  For i = 1 To iLastRow
    arr = Split(Cells(i, "A"), Chr(10))
    For j = 0 To UBound(arr)
      If arr(j) <> " " Then
        Cells(i, "B") = Cells(i, "B") & arr(j) & Chr(10)
      End If
    Next
  Next
End Sub
Разбиение (разделение) данных по отделам на несколько листов
 
FrinG, написал
Цитата
Очень прошу помочь в написании макроса.
А где ваши попытки? Или все нужно сделать с нуля за вас?
Макрос найти данные в определенной книги из активной книги, и перенести в определенную книгу
 
Обе книги должны быть открыты
Номера телефонов привести к единому формату
 
UDF формат +7(000)000-00-00
Код
Public Function RgxPhone(iString As Range) As String
 Dim re As Object
 Dim tempString
  Set re = CreateObject("vbscript.regexp")
    re.Pattern = "(-|\s|\+|\(|\))"
    re.Global = True
    re.IgnoreCase = True
 tempString = re.Replace(iString, "")
 re.Pattern = "((8)|(7))(\d{3})+(\d{3})+(\d{2})+(\d{2})+"
  If re.Test(tempString) Then
   RgxPhone = re.Replace(tempString, "$1$2($4) $5-$6-$7")
    If (Left(RgxPhone, 1) <> "8") Then
        RgxPhone = "+" + RgxPhone
    Else
       RgxPhone = "+7" + Mid(RgxPhone, 3)
    End If
  End If
End Function
Последние слова в ячейке оставить, От многословной фразы оставить формулой только последние три-четыре слова я ячейке
 
UDF  вызывается =WordsEnd(A1;" ";4)
Код
Function WordsEnd(cell As String, delimiter As String, n As Integer) As String
  Dim arr
  Dim i As Integer
  If Len(cell) - Len(Replace(cell, delimiter, "")) >= n Then
    arr = Split(cell, delimiter)
      For i = UBound(arr) - n + 1 To UBound(arr)
        WordsEnd = WordsEnd & arr(i) & delimiter
      Next
  Else
    WordsEnd = cell
  End If
End Function
Изменено: Kuzmich - 15 Янв 2020 20:31:51
Ошибка с макросом при изменении данных на листе, Ошибка Out of stack space при выполнении макроса с завязкой на изменение на листе
 
Макрос должен быть в модуле Лист1
Код
Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("B1:B2")) Is Nothing Then
   Application.Calculation = xlCalculationManual
   Application.EnableEvents = False
Dim m_pr, s_pr, d_pr, eq_f, eq_s As Single
  m_pr = Range("B1")
  s_pr = Range("B2")
  d_pr = 0
  Do Until eq_f < eq_s
    d_pr = d_pr + 0.01
    eq_f = m_pr / d_pr
    eq_s = 1.3 * d_pr / s_pr
    If eq_f < eq_s Then Exit Do
  Loop
     Range("B3") = d_pr
   Application.EnableEvents = True
   Application.Calculation = xlCalculationAutomatic
  End If
End Sub

При таком объявлении переменных, как у вас
Код
Dim m_pr, s_pr, d_pr, eq_f, eq_s As Single

Только eq_s As Single, остальные будут Variant
Удалиение строк. Оставить значения первого столбца с максимальным значением из второго столбца
 
Код
Sub DelRow()
Dim i As Long
Dim iLastRow As Long
Dim iMax As Double
Dim n As Long
Dim k As Long
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For i = iLastRow To 3 Step -1
    iMax = Cells(i, "B")
      n = i
    Do
     If Cells(n - 1, "A") = Cells(n, "A") Then
      If Cells(n - 1, "B") > Cells(n, "B") Then iMax = Cells(n - 1, "B")
      n = n - 1
     End If
    Loop While Cells(n - 1, "A") = Cells(n, "A")
    For k = i To n Step -1
      If Cells(k, "B") <> iMax Then Rows(k).Delete
    Next
      i = n
  Next
End Sub
Формирование таблицы уникальных товаров с более поздним номером прихода из базы данных
 
Тема: Формирование таблицы уникальных товаров с более поздним номером прихода из базы данных
Формирование таблицы уникальных товаров с более поздним номером прихода из базы данных
 
Код
Sub UnicTowar()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundTowar As Range
 iLastRow = Range("B4").End(xlDown).Row
 Range("G5:J" & iLastRow).Clear
 Range("C4:C" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("H4"), Unique:=True
 Range("B4:E4").Copy Range("G4")
 iLR = Cells(Rows.Count, "H").End(xlUp).Row
   For i = 5 To iLR
     Set FoundTowar = Range("C4:C" & iLastRow).Find(Cells(i, "H"), , xlValues, xlWhole, , xlPrevious)
     Cells(i, "J") = Cells(FoundTowar.Row, "E")
     Cells(i, "G") = Cells(FoundTowar.Row, "B")
   Next
   Range("G4:J" & iLR).Borders.Weight = xlThin
End Sub
[ Закрыто] Работа с таблицой, Объединение повторяющихся строк, сложение данных
 
Как артикул 0011 в примере превратился в 0012 ?
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 223 След.
Наверх