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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 224 След.
Перевернуть таблицу и посчитать сумму
 
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
Копирование данных в добавленные строки по критерию с помощью макроса
 
Grisha777999,
Возможно вам нужна не Вставка определенного кол-ва строк с помощью макроса VBA,
а копирование строк с листа "данные" между двумя датами?
Отображать в ячейках диапазона формулы
 
maria_gug,
Цитата
только теперь в ячейках вставлены формулы, а надо что бы были значения
На листе "объемные величины" в ячейках отображаются значения, но если выделить какую-либо
ячейку, то в строке формул мы видим формулу.
Отображать в ячейках диапазона формулы
 
maria_gug,
Цитата
чтоб в конечном итоге появились человеческие формулы?
Пробуйте
Код
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
Dim iFormula As String
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)
iFormula = iFormula & "'" & ArrList(n) & "'!" & .Cells(FoundCell.Row, FoundMonth.Column).Address(0, 0) & "+"
       End If
      End With
     Next
      'Cells(i, j) = Cells(i, j) / Tarif
      Cells(i, j).Formula = "=(" & Left(iFormula, Len(iFormula) - 1) & ")/" & Tarif
      iFormula = ""
    Next
  Next
Application.ScreenUpdating = True
End Sub
Перевернуть таблицу и посчитать сумму
 
Katerina Larionova,
Если исходник надо оставить нетронутым, то скопируйте содержимое в новый лист
и запустите макрос
Код
Sub Perevernut()
Dim i As Long
Dim iLastRow As Long
Dim Itog As Worksheet
 Set Itog = ThisWorkbook.Worksheets("итог")
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 With Itog
   .Cells.Clear
  For i = iLastRow To 3 Step -1
    If Cells(i - 1, "A") = Cells(i, "A") Then
      Range("B" & i & ":Q" & i).Copy
      Range("B" & i - 1).PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
      Rows(i).Delete Shift:=xlUp
    End If
  Next
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   Range("A1:Q" & iLastRow).Copy
   .Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
   .Activate
   Range("A1").Select
 End With
End Sub
Как увеличить объем используемой памяти и частоты процессора для Excel?
 
Цитата
взять более "ядерный" профессор
Может в МГУ или МИФИ есть  :D
Итоги данных листов с одинаковыми таблицами свести в один лист, с указанием имени исходного листа
 
thunder,
Пробуйте и учитесь применять в своих задачах
Код
Sub Vsego()
Dim Sht As Worksheet
Dim iLastRow As Long
Dim RngVsego As Range
 Application.ScreenUpdating = False
   iLastRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
     Range("B5:M" & iLastRow).Clear             'очищаем данные на листе СВОД по всего
 For Each Sht In Worksheets                       'цикл по всем листам книги
   If Sht.Name <> "исх" And Sht.Name <> "СВОД по всего" And Sht.Name <> "свод" Then ' кроме листов
      With Sht
        Set RngVsego = .Columns(3).Find("ВСЕГО", , xlValues, xlWhole)
        If Not RngVsego Is Nothing Then
           iLastRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
           Cells(iLastRow, "B") = .Name
           .Range("J" & RngVsego.Row & ":L" & RngVsego.Row).Copy
           Cells(iLastRow, "J").PasteSpecial xlPasteValues
           Range("J" & iLastRow & ":L" & iLastRow).NumberFormat = "#,##0.00"
        End If
      End With
   End If
 Next
Application.ScreenUpdating = True
End Sub
Получение дат из длинного формата даты
 
Код
If Replace(CDbl(CDate(Range("...."))), ",", ".") > Replace(CDbl(CDate(sdate)), ",", ".") 
Изменено: Kuzmich - 21 Янв 2020 12:26:35
Итоги данных листов с одинаковыми таблицами свести в один лист, с указанием имени исходного листа
 
thunder,
А ответов из вашей предыдущей темы
Цитата
https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=124217
Данные множества листов с одинаковыми таблицами свести в один лист
вам недостаточно для решения этой задачи?
Присвоить значение переменной
 
Нет ответа на вопрос, вот макрос
Код
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

Присвоить значение переменной
 
Цитата
Нужно значения т/год просуммировать
Куда выводить сумму и сколько знаков после запятой?
Присвоить значение переменной
 
Цитата
Надеюсь ясно выразился)
А где пример?
Подсветить повторы в столбце по двум условиям
 
Огласите, пожалуйста, весь список документов. Повторы идут друг за другом или могут быть в разных местах?
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 224 След.
Наверх