Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Пользователи » Diatr
Выбрать дату в календаре…Выбрать дату в календаре

Страницы: 1 2 3 4 5 6 След.
Подсчет переходов в строке с нуля на значение
 
#
20.03.2024 11:12:28
V, точно, ошибся в 3 строке)
Большое спасибо
 
Перейти    
Подсчет переходов в строке с нуля на значение
 
#
20.03.2024 09:37:21
Добрый день!

Подскажите, пожалуйста, как посчитать в строке моменты перехода с числа на ноль и с нуля на число

В файле примере должно посчитаться так:
Строка 1 = 4
Строка 2 = 6
Строка 3 = 2
 
Перейти    
Предсказание по нескольким столбцам
 
#
08.11.2023 11:08:34
МатросНаЗебре, Неправильный расчет получается, к примеру, вот задал число 170 из столбца D и выбрал 2 месяц. Ответ должен был получиться около 79
 
Перейти    
Предсказание по нескольким столбцам
 
#
08.11.2023 09:15:20
Добрый день!

Нужно реализовать, чтоб вбивая значение столбца D(можно еще добавить значение месяца), находилось значение столбца C(используя прогнозирование/интерполяцию).
Но при этом нужно учесть столбец A/B c наименованием месяцев, т.к в летние периоды значение в столбце С становится ниже.

Попробовал выводить уравнение полинома, функцию ПРЕДСКАЗ, но работает некорректно в данном случае.

Подскажите, пожалуйста, как это можно сделать.
 
Изменено: Diatr - 08.11.2023 09:35:53
 
Перейти    
Как убрать перекрытие данных на гистограмме?
 
#
17.08.2023 11:58:29
evgeniygeo, спасибо
 
Перейти    
Как убрать перекрытие данных на гистограмме?
 
#
17.08.2023 08:58:11
на этом скриншоте используется гистограмма с накоплением, вот тут все цвета показываются точно как я этого хочу. Но тогда вопрос как изменить ось, чтоб значения были от минимального к максимальному значению столбца, без складывания всех трех столбцов (изменить естественно не в параметрах оси с -50 до 60, т.к в таком случае у меня обрежутся бары)  
 
Перейти    
Как убрать перекрытие данных на гистограмме?
 
#
17.08.2023 07:54:45
evgeniygeo, в зависимости от столбцов, т.е я это явно выделяю. К примеру: для столбца 1 положительные числа светло-зеленые, отрицательные - светлокрасные. Для 2 столбца значения темно-зеленые и темно-красные
 
Перейти    
Как убрать перекрытие данных на гистограмме?
 
#
17.08.2023 07:49:18
еще один пример из 3 столбцов, мне нужно чтоб 3 столбца из скриншота объединились в один бар, чтоб при этом столбец с наибольшим значением не перекрывал цвет с наименьшим значением. Ось у при этом не должна мне показывать сумму положительных/отрицательных чисел, а строиться по классике, со значениями из столбца с наибольшим значением
Изменено: Diatr - 17.08.2023 07:53:14
 
Перейти    
Как убрать перекрытие данных на гистограмме?
 
#
17.08.2023 07:34:05
Добрый день!

Есть 2 столбца, на гистограмме нужно выделить значения этих столбцов разным цветом (отличие должно быть видно и для положительной, и для отрицательной части)

В моем файле есть 10 строк, для первых 7 данные совпали хорошо и можно увидеть какой результат я хочу получить. Для 8,9,10 происходит перекрытие, т.е столбец 2 полностью перекрывает выделенный другим цветом столбец 1.

Подскажите, пожалуйста, как это исправить. Гистограмма с накоплением не подойдет, т.к мне не нужна ось которая имеет суммированные значения столбцов
 
Перейти    
Потеря связей при копировании папки
 
#
04.07.2023 15:25:26
Добрый день!

У меня лежат папки с файлами, имеющие такой путь O:\СИП\ПК\2023\(далее идут папки январь, февраль и т.д)
В данной папке с наименованием месяца находится много файлов и других папок, когда я копирую, к примеру, папку июнь и переименовываю ее на июль, то в половине файлов связи меняются на "июль", а в остальной половине файлов связи остаются старые, т.е июньские.

Вопрос: Почему так происходит? Можно ли как-то более грамотно получить новую переименованную папку с копированными из старой папки файлами, с автоматически обновленными связями.

Структура папок одинаковая, все файлы имеют одинаковые наименования
 
Перейти    
Нарастающий итог с несколькими условиями
 
#
04.07.2023 14:47:53
Максим В., Павел с Востока \Ʌ/, большое спасибо! это то что нужно
 
Перейти    
Нарастающий итог с несколькими условиями
 
#
04.07.2023 13:56:49
Максим В., ваша формула сейчас работает так же как и моя, т.е нарастающий итог работает корректно, но нужно добавить еще несколько условий по столбцам, т.е если я в столбце год поменяю значение с 2023 на 2022 для станции 45 и показателя Выработка  -всего, я должен увидеть Выработку  -всего именно для 2022 года.
 
Перейти    
Нарастающий итог с несколькими условиями
 
#
04.07.2023 12:41:54
Добрый день!

У меня есть такая формула, считающая нарастающий итог(На Лист1 в ячейках D1 и D2 выбираем с какого по какой месяц должен быть нарастающий итог)
=СУММПРОИЗВ((ШАБЛОН!$F$1:$T$1=ИНДЕКС($U$3:$U$14;ПОИСКПОЗ($F$1;$U$3:$U$14;)):ИНДЕКС($U$3:$U$14;ПОИСКПОЗ($F$2;$U$3:$U$14;)))*ШАБЛОН!$F3:$T3)

Я хочу добавить к этой формуле проверку по нескольким условиям(столбцам)

Пробую сделать таким способом, но  получаю ошибки #Н/Д или Знач
=СУММПРОИЗВ((ШАБЛОН!$D$1:$R$1=ИНДЕКС($T$3:$T$14;ПОИСКПОЗ($E$1;$T$3:$T$14;)):ИНДЕКС($T$3:$T$14;ПОИСКПОЗ($E$2;$T$3:$T$14;)))*(ШАБЛОН!$B$2:$B$3000=Лист1!$B3)*(ШАБЛОН!$A$2:$A$3000=Лист1!$A3);ШАБЛОН!$D2:$R3000)

либо так

=СУММПРОИЗВ((ШАБЛОН!$D$1:$R$1=ИНДЕКС($T$3:$T$14;ПОИСКПОЗ($E$1;$T$3:$T$14;)):ИНДЕКС($T$3:$T$14;ПОИСКПОЗ($E$2;$T$3:$T$14;)))*(ШАБЛОН!$B$2:$B$3000=Лист1!$B3)*(ШАБЛОН!$A$2:$A$3000=Лист1!$A3)*ШАБЛОН!$D2:$R3000)

Подскажите, пожалуйста, как это можно реализовать? В чем моя ошибка?
Т.е моя конечная цель, это если произошли какие-то изменения в столбцах A/B/C, расчет должен подстраиваться под эти изменения, в том виде, в котором сделано у меня сейчас, задается явная строка $F3:$T3, хотелось бы задать сразу весь массив значений и выборку по столбцам
 
Перейти    
Объединить два работающих макроса по вставке формул
 
#
09.03.2023 08:31:55
Добрый день! Есть два работающих макроса по вставке формулы в книгу excel. Подскажите, пожалуйста, как можно их объединить в один

Макрос 1
Код
Public fso As Object
 
Sub ВставитьФормулу()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fullFrom As Variant
    fullFrom = ShowFileDialog("Выберите файл источник", False)
    If IsEmpty(fullFrom) Then Exit Sub
 
    Dim fullTarg As Variant
    fullTarg = ShowFileDialog("Выберите файлы приёмники", True)
    If IsEmpty(fullTarg) Then Exit Sub
     
    Dim wbFrom As Workbook
    Set wbFrom = GetWb(fullFrom(1))
     
    Dim vFull As Variant
    For Each vFull In fullTarg
        FillFormulasInWorkbook vFull, wbFrom
    Next
     
    wbFrom.Close False
End Sub
 
Private Sub FillFormulasInWorkbook(ByVal sFull As String, wbFrom As Workbook)
    Dim rr As Range
    Dim sh As Worksheet
    Dim wb As Workbook
    Set wb = GetWb(sFull)
      
    If Not wb Is Nothing Then
        Dim ss As String
        Dim vMonth As Variant
        For Each vMonth In Array("Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь")
            Set sh = wb.Sheets(vMonth)
            Set rr = sh.Range("G11:G15,G17:G20,G22,G24:G27,G29:G36,G38:G40,G42:G50,G52:G53,G55:G56,G59:G68,I11:I15,I17:I20,I22,I24:I27,I29:I36,I38:I40,I42:I50,I52:I53,I55:I56,I59:I68")
             
            ss = "=ЕСЛИОШИБКА(ИНДЕКС('[" & wbFrom.Name & "]Январь'!$G$11:$J$68;ПОИСКПОЗ($D11;'[" & wbFrom.Name & "]Январь'!$D$11:$D$68;0);ПОИСКПОЗ(G$9;'[" & wbFrom.Name & "]Январь'!$G$9:$J$9;0));" & """""" & ")"
            ss = Replace(ss, "Январь", vMonth)
            rr.FormulaLocal = ss
        Next
         
        wb.RemovePersonalInformation = 0
        wb.Close True
    End If
End Sub

Private Function GetWb(ByVal sFull As String) As Workbook
    Dim sName As String
    sName = fso.GetFileName(sFull)
     
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If wb.FullName <> sFull Or wb.ReadOnly Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
     
    Set GetWb = wb
End Function
 
Private Function ShowFileDialog(sTitle As String, bAllowMultiSelect As Boolean) As Variant
    Dim rInitialFileName As Range
    On Error Resume Next
    Set rInitialFileName = ThisWorkbook.Names("Файл").RefersToRange
 
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = bAllowMultiSelect
        .Title = sTitle
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function
Макрос 2. Вставляет данную формулу на другие листы и ячейки.

Код
Public fso As Object
 
Sub ВставитьФормулу()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fullFrom As Variant
    fullFrom = ShowFileDialog("Выберите файл источник", False)
    If IsEmpty(fullFrom) Then Exit Sub
 
    Dim fullTarg As Variant
    fullTarg = ShowFileDialog("Выберите файлы приёмники", True)
    If IsEmpty(fullTarg) Then Exit Sub
     
    Dim wbFrom As Workbook
    Set wbFrom = GetWb(fullFrom(1))
     
    Dim vFull As Variant
    For Each vFull In fullTarg
        FillFormulasInWorkbook vFull, wbFrom
    Next
     
    wbFrom.Close False
End Sub
 
Private Sub FillFormulasInWorkbook(ByVal sFull As String, wbFrom As Workbook)
    Dim rr As Range
    Dim sh As Worksheet
    Dim wb As Workbook
    Set wb = GetWb(sFull)
      
    If Not wb Is Nothing Then
        Dim ss As String
        Dim vMonth As Variant
        For Each vMonth In Array("I квартал", "II квартал", "III квартал", "IV квартал", "Год")
            Set sh = wb.Sheets(vMonth)
            Set rr = sh.Range("G30:J30,G65:J68")
             
            ss = "=ЕСЛИОШИБКА(ИНДЕКС('[" & wbFrom.Name & "]I квартал'!$G$11:$J$68;ПОИСКПОЗ($D30;'[" & wbFrom.Name & "]I квартал'!$D$11:$D$68;0);ПОИСКПОЗ(G$9;'[" & wbFrom.Name & "]I квартал'!$G$9:$J$9;0));" & """""" & ")"
            ss = Replace(ss, "I квартал", vMonth)
            rr.FormulaLocal = ss
        Next
         
        wb.RemovePersonalInformation = 0
        wb.Close True
    End If
End Sub

Private Function GetWb(ByVal sFull As String) As Workbook
    Dim sName As String
    sName = fso.GetFileName(sFull)
     
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If wb.FullName <> sFull Or wb.ReadOnly Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
     
    Set GetWb = wb
End Function
 
Private Function ShowFileDialog(sTitle As String, bAllowMultiSelect As Boolean) As Variant
    Dim rInitialFileName As Range
    On Error Resume Next
    Set rInitialFileName = ThisWorkbook.Names("Файл").RefersToRange
 
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = bAllowMultiSelect
        .Title = sTitle
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function
Изменено: Diatr - 09.03.2023 08:34:18
 
Перейти    
Добавить в макрос копирование ячеек на другие листы.
 
#
09.03.2023 07:09:48
Код
Public fso As Object
 
Sub ВставитьФормулу()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fullFrom As Variant
    fullFrom = ShowFileDialog("Выберите файл источник", False)
    If IsEmpty(fullFrom) Then Exit Sub
 
    Dim fullTarg As Variant
    fullTarg = ShowFileDialog("Выберите файлы приёмники", True)
    If IsEmpty(fullTarg) Then Exit Sub
     
    Dim wbFrom As Workbook
    Set wbFrom = GetWb(fullFrom(1))
     
    Dim vFull As Variant
    For Each vFull In fullTarg
        FillFormulasInWorkbook vFull, wbFrom
        FillFormulasInWorkbookk vFull, wbFrom
    Next
     
    wbFrom.Close False
End Sub
 
Private Sub FillFormulasInWorkbook(ByVal sFull As String, wbFrom As Workbook)
    Dim rr As Range
    Dim sh As Worksheet
    Dim wb As Workbook
    Set wb = GetWb(sFull)
      
    If Not wb Is Nothing Then
        Dim ss As String
        Dim vMonth As Variant
        For Each vMonth In Array("Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь")
            Set sh = wb.Sheets(vMonth)
            Set rr = sh.Range("G11:G15,G17:G20,G22,G24:G27,G29:G36,G38:G40,G42:G50,G52:G53,G55:G56,G59:G68,I11:I15,I17:I20,I22,I24:I27,I29:I36,I38:I40,I42:I50,I52:I53,I55:I56,I59:I68")
             
            ss = "=ЕСЛИОШИБКА(ИНДЕКС('[" & wbFrom.Name & "]Январь'!$G$11:$J$68;ПОИСКПОЗ($D11;'[" & wbFrom.Name & "]Январь'!$D$11:$D$68;0);ПОИСКПОЗ(G$9;'[" & wbFrom.Name & "]Январь'!$G$9:$J$9;0));" & """""" & ")"
            ss = Replace(ss, "Январь", vMonth)
            rr.FormulaLocal = ss
        Next
         
        wb.RemovePersonalInformation = 0
        wb.Close True
    End If
End Sub
Private Sub FillFormulasInWorkbookk(ByVal sFull As String, wbFrom As Workbook)
    Dim rrr As Range
    Dim shh As Worksheet
    Dim wbb As Workbook
    Set wbb = GetWb(sFull)
      
    If Not wbb Is Nothing Then
        Dim sss As String
        Dim vMonthh As Variant
        For Each vMonthh In Array("I квартал", "II квартал", "III квартал", "IV квартал", "Год")
            Set shh = wb.Sheets(vMonthh)
            Set rrr = sh.Range("G30:J30,G65:J68")
             
            sss = "=ЕСЛИОШИБКА(ИНДЕКС('[" & wbFrom.Name & "]I квартал'!$G$11:$J$68;ПОИСКПОЗ($D11;'[" & wbFrom.Name & "]I квартал'!$D$11:$D$68;0);ПОИСКПОЗ(G$9;'[" & wbFrom.Name & "]I квартал'!$G$9:$J$9;0));" & """""" & ")"
            sss = Replace(sss, "I квартал", vMonthh)
            rrr.FormulaLocal = sss
        Next
         
        wbb.RemovePersonalInformation = 0
        wbb.Close True
    End If
End Sub
 
Private Function GetWb(ByVal sFull As String) As Workbook
    Dim sName As String
    sName = fso.GetFileName(sFull)
     
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If wb.FullName <> sFull Or wb.ReadOnly Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
     
    Set GetWb = wb
End Function
 
Private Function ShowFileDialog(sTitle As String, bAllowMultiSelect As Boolean) As Variant
    Dim rInitialFileName As Range
    On Error Resume Next
    Set rInitialFileName = ThisWorkbook.Names("Файл").RefersToRange
 
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = bAllowMultiSelect
        .Title = sTitle
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Еще пробовал в первом варианте просто добавить дополнительные листы. Все ячейки кроме нужных мне("G30:J30,G65:J68") заблокированы на данных листах, так что думал может сработать, но нет). В этом варианте - данные вставляются корректно на все листы с наименованием месяца + на лист "I квартал", а "II квартал", "III квартал", "IV квартал", "Год" почему-то упускает, ячейки остаются незаполненными
Код
   For Each vMonth In Array("Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь", "I квартал", "II квартал", "III квартал", "IV квартал", "Год")
            Set sh = wb.Sheets(vMonth)
            Set rr = sh.Range("G11:G15,G17:G20,G22,G24:G27,G29:G36,G38:G40,G42:G50,G52:G53,G55:G56,G59:G68,I11:I15,I17:I20,I22,I24:I27,I29:I36,I38:I40,I42:I50,I52:I53,I55:I56,I59:I68")
Изменено: Diatr - 09.03.2023 07:58:01
 
Перейти    
Добавить в макрос копирование ячеек на другие листы.
 
#
09.03.2023 07:09:05
Добрый день! Сейчас у меня есть такой макрос, вставляющий формулу на нужные мне листы из одной книги в другую.

Хочу добавить в этот макрос  аналогичную вставку значений на листы "I квартал", "II квартал", "III квартал", "IV квартал", "Год" в ячейки "G30:J30,G65:J68"

Но что-то не получается у меня, подскажите пожалуйста как правильно это сделать?

P.S Первым комментарием выложу код моей попытки
Код
Public fso As Object
 
Sub ВставитьФормулу()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fullFrom As Variant
    fullFrom = ShowFileDialog("Выберите файл источник", False)
    If IsEmpty(fullFrom) Then Exit Sub
 
    Dim fullTarg As Variant
    fullTarg = ShowFileDialog("Выберите файлы приёмники", True)
    If IsEmpty(fullTarg) Then Exit Sub
     
    Dim wbFrom As Workbook
    Set wbFrom = GetWb(fullFrom(1))
     
    Dim vFull As Variant
    For Each vFull In fullTarg
        FillFormulasInWorkbook vFull, wbFrom
    Next
     
    wbFrom.Close False
End Sub
 
Private Sub FillFormulasInWorkbook(ByVal sFull As String, wbFrom As Workbook)
    Dim rr As Range
    Dim sh As Worksheet
    Dim wb As Workbook
    Set wb = GetWb(sFull)
      
    If Not wb Is Nothing Then
        Dim ss As String
        Dim vMonth As Variant
        For Each vMonth In Array("Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь")
            Set sh = wb.Sheets(vMonth)
            Set rr = sh.Range("G11:G15,G17:G20,G22,G24:G27,G29:G36,G38:G40,G42:G50,G52:G53,G55:G56,G59:G68,I11:I15,I17:I20,I22,I24:I27,I29:I36,I38:I40,I42:I50,I52:I53,I55:I56,I59:I68")
             
            ss = "=ЕСЛИОШИБКА(ИНДЕКС('[" & wbFrom.Name & "]Январь'!$G$11:$J$68;ПОИСКПОЗ($D11;'[" & wbFrom.Name & "]Январь'!$D$11:$D$68;0);ПОИСКПОЗ(G$9;'[" & wbFrom.Name & "]Январь'!$G$9:$J$9;0));" & """""" & ")"
            ss = Replace(ss, "Январь", vMonth)
            rr.FormulaLocal = ss
        Next
         
        wb.RemovePersonalInformation = 0
        wb.Close True
    End If
End Sub

Private Function GetWb(ByVal sFull As String) As Workbook
    Dim sName As String
    sName = fso.GetFileName(sFull)
     
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If wb.FullName <> sFull Or wb.ReadOnly Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
     
    Set GetWb = wb
End Function
 
Private Function ShowFileDialog(sTitle As String, bAllowMultiSelect As Boolean) As Variant
    Dim rInitialFileName As Range
    On Error Resume Next
    Set rInitialFileName = ThisWorkbook.Names("Файл").RefersToRange
 
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = bAllowMultiSelect
        .Title = sTitle
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function
 
Перейти    
Просмотр изменений в excel.
 
#
01.02.2023 06:35:50
MikeVol, Добрый день! Вопрос пока стоял на паузе, т.к задавать кучу переменных было неудобно, посмотрел ваше решение, большое спасибо! Думаю буду использовать его, переписав на нужные ячейки и заменив комментарии на русский язык
 
Перейти    
Просмотр изменений в excel.
 
#
25.01.2023 18:18:45
evgeniygeo, Спасибо
 
Перейти    
Просмотр изменений в excel.
 
#
25.01.2023 15:06:38
evgeniygeo, ох, ячеек то многовато будет) а с листами получится так как я описал выше?
Диапазонами получается не задать в таком варианте макроса?

Вариантом в лоб что-то не получается, выдает Run time error 450, при нажатии Debug указывается данная строка zapas = Sheets("Выработка").Range("F141", "G141", "H141", "I141", "J141", "K141", "L141", "M141", "N141", "O141", "P141", "Q141").Text
Код
Dim zapas
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
zapas = Sheets("Выработка").Range("F141", "G141", "H141", "I141", "J141", "K141", "L141", "M141", "N141", "O141", "P141", "Q141").Text
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
On Error Resume Next
Application.EnableEvents = False
было = zapas
Application.EnableEvents = True
стало = Sheets("Выработка").Range("F141", "G141", "H141", "I141", "J141", "K141", "L141", "M141", "N141", "O141", "P141", "Q141").Text
If было <> стало Then
    Set oComment = Sheets("Выработка").Range("F141", "G141", "H141", "I141", "J141", "K141", "L141", "M141", "N141", "O141", "P141", "Q141").Comment
    If oComment Is Nothing Then
        Sheets("Выработка").Range("F141", "G141", "H141", "I141", "J141", "K141", "L141", "M141", "N141", "O141", "P141", "Q141").AddComment Date & " было: " & было & " стало: " & стало
    Else
        oComment.Text oComment.Text & Chr(10) & Date & " было: " & было & " стало: " & стало
    End If
    oComment.Shape.TextFrame.AutoSize = True
End If
End Sub
Изменено: Diatr - 25.01.2023 15:28:00
 
Перейти    
Просмотр изменений в excel.
 
#
25.01.2023 14:38:10
evgeniygeo, Большое спасибо! Сейчас работает для одной ячейки которую я задаю в макросе, но когда меняю Range("F141") на Range("F141:Q141"), макрос перестает показывать изменения, подскажите как правильно диапазон задать чтоб работало(я нужные сам расставлю) ? Я в VBA слаб, но раньше всегда в таком виде диапазоны в макросах указывал, аналогичный вопрос для указания листов в книге excel Sheets("Выработка") просто меняю Sheets(Array("Sheet1", "Sheet2")), больше никаких изменений не будет?  
 
Перейти    
Просмотр изменений в excel.
 
#
25.01.2023 13:11:34
evgeniygeo, Вот именно это и хотелось увидеть! но данный макрос не работает при моих условиях(часть исходных данных использующихся в формулах на другом листе) :(

В приложении прикреплен ваш файл, где я создал дополнительный лист и аргументы СУММ перенес на новый лист, макрос уже не работает
В своем же файле ничего не менял, просто поставил макрос на ячейку F141(так же проверено на ячейках со скоростью ветра и КИУМ на листе чистая выработка)
Изменено: Diatr - 25.01.2023 13:12:08
 
Перейти    
Изменить макрос по вставке ячеек из другой книги.
 
#
25.01.2023 12:13:51
Добрый день! Есть такой макрос, вставляющий формулу в определенные ячейки одного файла, используя связь с другим файлом.(оба файлы имели одинаковые наименования листов, да и вообще всю структуру)

Сейчас нужно сделать тоже самое(вставить формулу имеющую связь с другим файлом), только иметь возможность выбрать лист откуда будут браться данные из файла источника.

Файл приемник - тот же самый формат и структура
Файл источник - другой формат, другие наименования листов. Все данные будут браться с одного листа (к примеру, лист с именем "ТЭЦ",  ну а сама формула вставлятся во все листы файла приемника как и раньше, тут без изменений)

Подскажите пожалуйста как изменить макрос.
Заранее большое спасибо!
Код
Public fso As Object
 
Sub ВставитьФормулу()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fullFrom As Variant
    fullFrom = ShowFileDialog("Выберите файл источник", False)
    If IsEmpty(fullFrom) Then Exit Sub
 
    Dim fullTarg As Variant
    fullTarg = ShowFileDialog("Выберите файлы приёмники", True)
    If IsEmpty(fullTarg) Then Exit Sub
     
    Dim wbFrom As Workbook
    Set wbFrom = GetWb(fullFrom(1))
     
    Dim vFull As Variant
    For Each vFull In fullTarg
        FillFormulasInWorkbook vFull, wbFrom
    Next
     
    wbFrom.Close False
End Sub
 
Private Sub FillFormulasInWorkbook(ByVal sFull As String, wbFrom As Workbook)
    Dim rr As Range
    Dim sh As Worksheet
    Dim wb As Workbook
    Set wb = GetWb(sFull)
      
    If Not wb Is Nothing Then
        Dim ss As String
        Dim vMonth As Variant
        For Each vMonth In Array("Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь")
            Set sh = wb.Sheets(vMonth)
            Set rr = sh.Range("G11:G15,G17:G20,G22,G24:G27,G29:G36,G38:G40,G42:G50,G52:G53,G55:G56,G59:G68,I11:I15,I17:I20,I22,I24:I27,I29:I36,I38:I40,I42:I50,I52:I53,I55:I56,I59:I68")
             
            ss = "=ЕСЛИОШИБКА(ИНДЕКС('[" & wbFrom.Name & "]Январь'!$G$11:$J$68;ПОИСКПОЗ($E11;'[" & wbFrom.Name & "]Январь'!$E$11:$E$68;0);ПОИСКПОЗ(G$9;'[" & wbFrom.Name & "]Январь'!$G$9:$J$9;0));" & """""" & ")"
            ss = Replace(ss, "Январь", vMonth)
            rr.FormulaLocal = ss
        Next
         
        wb.RemovePersonalInformation = 0
        wb.Close True
    End If
End Sub
 
Private Function GetWb(ByVal sFull As String) As Workbook
    Dim sName As String
    sName = fso.GetFileName(sFull)
     
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If wb.FullName <> sFull Or wb.ReadOnly Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
     
    Set GetWb = wb
End Function
 
Private Function ShowFileDialog(sTitle As String, bAllowMultiSelect As Boolean) As Variant
    Dim rInitialFileName As Range
    On Error Resume Next
    Set rInitialFileName = ThisWorkbook.Names("Файл").RefersToRange
 
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = bAllowMultiSelect
        .Title = sTitle
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function
Изменено: Diatr - 25.01.2023 12:14:48
 
Перейти    
Просмотр изменений в excel.
 
#
25.01.2023 11:42:22
Ігор Гончаренко, Такой вопрос уже не будет стоять, интерес только увидеть прошлый и нынешний результат в определенных месяцах)
 
Перейти    
Просмотр изменений в excel.
 
#
25.01.2023 11:23:11
evgeniygeo,
Цитата
написал:
так в чем сейчас проблема то? Вам же дали варианты, осталось только применить к Вашей задаче
Макросы работают только для ячеек без формул, т.е листа "Ввод исходных данных", я думал все таки можно как-то реализовать макросом тоже самое, но для листа "Чистая выработка" без создавания копий всех листов каждый раз при пересчете значений
Изменено: Diatr - 25.01.2023 11:24:47
 
Перейти    
Просмотр изменений в excel.
 
#
25.01.2023 08:45:05
MikeVol, evgeniygeo, Спасибо, но мне нужно видеть изменения на всех листах кроме "исходные данные",

На листе чистая выработка почти все ячейки имеют либо ссылку связями, либо формулу(которая пересчитывается каждый раз при изменении исходных данных(скорость ветра и часы простоя)

Вот нужно видеть именно пересчет этих формул, т.е к примеру, была скорость ветра в ВЭС 1 = 6.5 а Wпрогноз = 12810, изменили скорость ветра на 10, Wпрогноз стал = 43372(формула сама все посчитала, я меняю только значения скорости ветра и часов простоя в исходных данных, больше абсолютно ничего не трогаю)

Хочется увидеть: Навели курсор на ячейку Wпрогноз и показывается комментарием "прошлое значение: 12810"

В этот раз все очень подробно написал, извиняюсь если изначально плохо объяснил

P.S рассматриваю все возможные варианты, если намного проще реализовать это в другом виде
Для скорости работы можно сделать только для ячеек Wпрогноз, КИУМ, скорость ветра, остальные не нужны
Изменено: Diatr - 25.01.2023 08:51:51
 
Перейти    
Просмотр изменений в excel.
 
#
25.01.2023 08:27:35
evgeniygeo, Спасибо за предложение, к сожалению, листов достаточно много и скорее всего будет нецелесообразно каждый раз создавать копии этих листов при пересчете..
но как идея интересно, первый рабочий вариант для ячеек с формулами
 
Перейти    
Просмотр изменений в excel.
 
#
25.01.2023 06:31:42
MikeVol, Доброе утро! К сожалению, это работает только для ячеек в которых нет формул/функций
 
Перейти    
Просмотр изменений в excel.
 
#
24.01.2023 14:39:27
evgeniygeo, Спасибо, когда искал информацию натыкался на данные статьи, к сожалению, данные макросы не учитывают ячейки с формулами
 
Перейти    
Просмотр изменений в excel.
 
#
24.01.2023 13:36:58
Григорий Калюга, Значения, которые я буду менять, находятся только на листе "исходные данные" - скорость ветра и часы простоя, на всех остальных листах все значения прописаны формулами или связями( при изменении скорости ветра или часов простоя на листе исходные данные будут пересчитываться формулы на всех остальных листах)
Изменено: Diatr - 24.01.2023 13:41:18
 
Перейти    
Просмотр изменений в excel.
 
#
24.01.2023 12:18:05
Нашел еще вот такой макрос и проверил работоспособность, может его будет проще исправить, работает также как предыдущий

Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewCellValue$, OldComment$
Dim cell As Range


If Intersect(Target, Range("F:S")) Is Nothing Then Exit Sub


For Each cell In Intersect(Target, Range("F:S"))
If IsEmpty(cell) Then
NewCellValue = "Ячейка очищена"
Else
NewCellValue = cell.Formula
End If
On Error Resume Next

With cell
OldComment = .Comment.Text & Chr(10)
.Comment.Delete
.AddComment
.Comment.Text Text:=OldComment & Application.UserName & " " & _
Format(Now, "MM.DD.YY h:MM:ss") & " : " & NewCellValue
.Comment.Shape.TextFrame.AutoSize = True
.Comment.Shape.TextFrame.Characters.Font.Size = 8
End With
Next cell
End Sub
 
Перейти    
Страницы: 1 2 3 4 5 6 След.
Наверх