Страницы: 1
RSS
Извлечь из таблицы только строки со стоимостью работ при наличии подчиненных строк
 
Добрый день, пример во вложении:
Вывод результата необходим на отдельный лист
Есть у кого-то что-то подобное в наработках?
Изменено: vikttur - 24.11.2021 14:42:02
 
Добрый день. Структура исходных данных в файле-примере есть, а вот в каком виде необходим результат - нет.
Удивление есть начало познания © Surprise me!
И да пребудет с нами сила ВПР.
 
Результат на этом же листе с 47-й строки показал  
 
Код
Option Explicit

Sub Reorganize()
    Dim arr As Variant
    arr = GetArr(ActiveSheet)
    Dim frr As Variant
    frr = GetNoEmptyRowArr(arr)
    If Not IsEmpty(frr) Then
        OutArr frr
    End If
End Sub

Sub OutArr(arr As Variant)
    With Workbooks.Add(1)
        With .Sheets(1)
            With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Cells = arr
            End With
        End With
        .Saved = True
    End With
End Sub

Function GetNoEmptyRowArr(arr As Variant) As Variant
    Dim y As Long
    Dim n As Long
    For y = 3 To UBound(arr, 1)
        n = n + 1 + IsEmpty(arr(y, 1))
    Next
    If n > 0 Then
        Dim brr As Variant
        ReDim brr(1 To n, 1 To UBound(arr, 2))
        Dim x As Integer
        n = 0
        For y = 3 To UBound(arr, 1)
            If Not IsEmpty(arr(y, 1)) Then
                n = n + 1
                For x = 1 To UBound(arr, 2)
                    brr(n, x) = arr(y, x)
                Next
            End If
        Next
        GetNoEmptyRowArr = brr
    End If
End Function

Function GetArr(sh As Worksheet) As Variant
    With sh
        GetArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp).Cells(1, 11))
    End With
End Function
 
Спасибо почти все что нужно, но не до конца все условия
должно быть разность общие затраты минус то что до подчеркивания с не пустым K
Выделил в результат
Изменено: Тимофеев - 24.11.2021 09:31:50
 
>>> должно быть разность общие затраты минус то что до подчеркивания с не пустым K
может проще эти подсчеты в исходной таблице сделать?
Изменено: Ёк-Мок - 24.11.2021 09:36:18
Удивление есть начало познания © Surprise me!
И да пребудет с нами сила ВПР.
 
Для реорганизации структуры сметы проще сделать выборку по таким условиям один раз а не делать это в исходниках формулами
Структура всегда такая почти все возможные варианты при 11 графке показаны
Почитав форум профильно связан с этим вопросом Jack Famous, может у него есть какой совет
Изменено: Тимофеев - 24.11.2021 09:40:02
 
Цитата
написал:
почти все что нужно, но не до конца все условия
Не нашёл разницу между результатом из сообщения #5 и результатом макроса на данных из сообщения #1.
 
, , Строка 1 Результат: должно быть в K1=J15-K10-K9 из исходника
Если до подчеркивания в столбце А несколько строк не пусто, то в первой строке результата разность Общие затраты и K позиций 1.1 и 1.2
Изменено: Тимофеев - 24.11.2021 10:02:37
 
Код
Option Explicit
'v2
Sub Reorganize()
    Dim arr As Variant
    arr = GetArr(ActiveSheet)
    Dim frr As Variant
    frr = GetNoEmptyRowArr(arr)
    If Not IsEmpty(frr) Then
        OutArr frr
    End If
End Sub

Sub OutArr(arr As Variant)
    With Workbooks.Add(1)
        With .Sheets(1)
            With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Cells = arr
            End With
        End With
        .Saved = True
    End With
End Sub

Function GetNoEmptyRowArr(arr As Variant) As Variant
    Dim y As Long
    Dim n As Long
    For y = 3 To UBound(arr, 1)
        n = n + 1 + IsEmpty(arr(y, 1))
    Next
    If n > 0 Then
        Dim brr As Variant
        ReDim brr(1 To n, 1 To UBound(arr, 2))
        Dim x As Integer
        Dim yOZ As Long
        n = 0
        For y = 3 To UBound(arr, 1)
            If Not IsEmpty(arr(y, 1)) Then
                n = n + 1
                For x = 1 To UBound(arr, 2)
                    brr(n, x) = arr(y, x)
                Next
                
                If yOZ = 0 Then
                    yOZ = n
                    'brr(yOZ, 11) = 0
                End If
                brr(yOZ, 11) = brr(yOZ, 11) - arr(y, 11)
            End If
            If arr(y, 3) = "Общие затраты:" Then
                brr(yOZ, 11) = brr(yOZ, 11) + arr(y, 10)
                yOZ = 0
            End If
        Next
        GetNoEmptyRowArr = brr
    End If
End Function

Function GetArr(sh As Worksheet) As Variant
    With sh
        GetArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 3).End(xlUp).Cells(1, 11 - 2))
    End With
End Function
Изменено: МатросНаЗебре - 24.11.2021 10:27:12
 
Спасибо - НЕ все как в аптеке
МатросНаЗебре, файл шаблон с макросом диалоговое окно выбора файла и листа и далее это процедура - сложны в реализации?
Еще одна неточность файл с макросом во вложении:
Результат 11 и 12 строка. 11 должно быть пусто 12 то что сейчас в 11
P.S.: Столбцы F и J в результате можно не выводить добавка столбца 1,2*последний столбец если не пусто
Причесать вид вывода перенос по строкам подгонка в А4 альбом
Получится в общем отличный комбайн если это все отловить
Изменено: Тимофеев - 24.11.2021 10:55:16
 
Правки по форматированию.
Код
Option Explicit
'v3
Sub Reorganize()
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = ActiveSheet
    Dim arr As Variant
    arr = GetArr(sh1)
    Set sh2 = GetSh2(sh1)
    
    Dim frr As Variant
    frr = GetNoEmptyRowArr(arr, sh1, sh2)
    If Not IsEmpty(frr) Then
        OutArr frr, sh2
    End If
    
    Application.Calculation = Application_Calculation
End Sub

Function GetSh2(sh1 As Worksheet) As Worksheet
    Dim sh2 As Worksheet
    sh1.Copy
    Set sh2 = ActiveSheet
    sh2.Cells.Clear
    
    Set GetSh2 = sh2
End Function

Sub OutArr(arr As Variant, sh2 As Worksheet)
    'With Workbooks.Add(1)
    With sh2.Parent
        With .Sheets(1)
            With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Cells = arr
            End With
        End With
        .Saved = True
    End With
End Sub

Function GetNoEmptyRowArr(arr As Variant, sh1 As Worksheet, sh2 As Worksheet) As Variant
    Dim y As Long
    Dim n As Long
    For y = 3 To UBound(arr, 1)
        n = n + 1 + IsEmpty(arr(y, 1))
    Next
    If n > 0 Then
        Dim brr As Variant
        ReDim brr(1 To n, 1 To UBound(arr, 2))
        Dim x As Integer
        Dim yOZ As Long
        n = 0
        For y = 3 To UBound(arr, 1)
            If Not IsEmpty(arr(y, 1)) Then
                n = n + 1
                For x = 1 To UBound(arr, 2)
                    brr(n, x) = arr(y, x)
                    If x > 4 Then
                        If x < 11 Then
                            If brr(n, x) = "" Then
                                brr(n, x) = "'"
                            End If
                        End If
                    End If
                Next
                
                If yOZ = 0 Then
                    yOZ = n
                    'brr(yOZ, 11) = 0
                End If
                If IsNumeric(brr(yOZ, 11)) Then
                    If IsNumeric(arr(y, 11)) Then
                        brr(yOZ, 11) = brr(yOZ, 11) - arr(y, 11)
                    End If
                End If
                
                sh1.Rows(y).Copy sh2.Cells(n, 1)
            End If
            If arr(y, 3) = "Общие затраты:" Then
                If IsNumeric(brr(yOZ, 11)) Then
                    If IsNumeric(arr(y, 10)) Then
                        brr(yOZ, 11) = brr(yOZ, 11) + arr(y, 10)
                    End If
                End If
                yOZ = 0
            End If
        Next
        GetNoEmptyRowArr = brr
    End If
End Function

Function GetArr(sh As Worksheet) As Variant
    With sh
        GetArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 3).End(xlUp).Cells(1, 11 - 2))
    End With
End Function
 
Получается такая Логика вроде:
А и В пусто пропуск
А не пусто В пусто = К
А и В не пусто и нет до общие затраты в А значений = Общие затраты
А и В не пусто и есть до общие затраты в А значения =  Общие затраты - сумм(K этих значений)
По форматированию во вновь созданной книге Формат Альбомная колонитулы в ноль, поля 5,10,5,5
Изменено: Тимофеев - 24.11.2021 11:12:36
 
С диалогами.
Файл из #11 у меня скачивается.
Код
Option Explicit
'v4
Sub ReorganizeWithDialog()
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual

    Dim wb As Workbook
    Set wb = ShowFileDialog()
    If Not wb Is Nothing Then
        Application.Dialogs(xlDialogWorkgroup).Show ActiveSheet.Name
        Reorganize
        wb.Close False
    End If
    
    Application.Calculation = Application_Calculation
End Sub

Function ShowFileDialog() As Workbook
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Title = "Выбрать файлы отчетов" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Name 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To 1 '.SelectedItems.Count
            x = .SelectedItems(lf) 'считываем полный путь к файлу
            Set ShowFileDialog = Workbooks.Open(x) 'открытие книги
            'можно также без х
            'Workbooks.Open .SelectedItems(lf)
        Next
    End With
End Function

Sub Reorganize()
    
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = ActiveSheet
    Dim arr As Variant
    arr = GetArr(sh1)
    Set sh2 = GetSh2(sh1)
    
    Dim frr As Variant
    frr = GetNoEmptyRowArr(arr, sh1, sh2)
    If Not IsEmpty(frr) Then
        OutArr frr, sh2
    End If
    
End Sub

Function GetSh2(sh1 As Worksheet) As Worksheet
    Dim sh2 As Worksheet
    sh1.Copy
    Set sh2 = ActiveSheet
    sh2.Cells.Clear
    
    Set GetSh2 = sh2
End Function

Sub OutArr(arr As Variant, sh2 As Worksheet)
    'With Workbooks.Add(1)
    With sh2.Parent
        With .Sheets(1)
            With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Cells = arr
            End With
        End With
        .Saved = True
    End With
End Sub

Function GetNoEmptyRowArr(arr As Variant, sh1 As Worksheet, sh2 As Worksheet) As Variant
    Dim y As Long
    Dim n As Long
    For y = 3 To UBound(arr, 1)
        n = n + 1 + IsEmpty(arr(y, 1))
    Next
    If n > 0 Then
        Dim brr As Variant
        ReDim brr(1 To n, 1 To UBound(arr, 2))
        Dim x As Integer
        Dim yOZ As Long
        n = 0
        For y = 3 To UBound(arr, 1)
            If Not IsEmpty(arr(y, 1)) Then
                n = n + 1
                For x = 1 To UBound(arr, 2)
                    brr(n, x) = arr(y, x)
                    If x > 4 Then
                        If x < 11 Then
                            If brr(n, x) = "" Then
                                brr(n, x) = "'"
                            End If
                        End If
                    End If
                Next
                
                If yOZ = 0 Then
                    yOZ = n
                    'brr(yOZ, 11) = 0
                End If
                If IsNumeric(brr(yOZ, 11)) Then
                    If IsNumeric(arr(y, 11)) Then
                        brr(yOZ, 11) = brr(yOZ, 11) - arr(y, 11)
                    End If
                End If
                
                sh1.Rows(y).Copy sh2.Cells(n, 1)
            End If
            If arr(y, 3) = "Общие затраты:" Then
                If IsNumeric(brr(yOZ, 11)) Then
                    If IsNumeric(arr(y, 10)) Then
                        brr(yOZ, 11) = brr(yOZ, 11) + arr(y, 10)
                    End If
                End If
                yOZ = 0
            End If
        Next
        GetNoEmptyRowArr = brr
    End If
End Function

Function GetArr(sh As Worksheet) As Variant
    With sh
        GetArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 3).End(xlUp).Cells(1, 11 - 2))
    End With
End Function

 
Диалог крут сразу наименование листов выводит всех открытых книг (теоретически выбранная нужна)
Созданный файл по имени открытого с индексом добавочным каким-либо сохранять бы
Логика еще из 11 не до конца правильна
 
С сохранением файла с индексом.
Код
Option Explicit
'v5
Sub ReorganizeWithDialog()
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
 
    Dim wb As Workbook
    Set wb = ShowFileDialog()
    If Not wb Is Nothing Then
        Application.Dialogs(xlDialogWorkgroup).Show ActiveSheet.Name
        Reorganize wb
        wb.Close False
    End If
     
    Application.Calculation = Application_Calculation
End Sub
 
Function ShowFileDialog() As Workbook
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Title = "Выбрать файлы отчетов" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Name 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To 1 '.SelectedItems.Count
            x = .SelectedItems(lf) 'считываем полный путь к файлу
            Set ShowFileDialog = Workbooks.Open(x) 'открытие книги
            'можно также без х
            'Workbooks.Open .SelectedItems(lf)
        Next
    End With
End Function
 
Sub Reorganize(wb As Workbook)
     
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = ActiveSheet
    Dim arr As Variant
    arr = GetArr(sh1)
    Set sh2 = GetSh2(sh1)
     
    Dim frr As Variant
    frr = GetNoEmptyRowArr(arr, sh1, sh2)
    If Not IsEmpty(frr) Then
        OutArr frr, sh2
        SaveWb sh2.Parent, wb
    End If
     
End Sub
 
Sub SaveWb(wb2 As Workbook, wb1 As Workbook)
    Dim newName As String
    newName = GetNewName(wb1.Name)
    newName = wb1.Path & "\" & newName
    On Error Resume Next
    Kill newName
    On Error GoTo 0
    wb2.SaveAs Filename:=newName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    'wb2.Close
End Sub

Function GetNewName(ByVal oldName As String) As String
    oldName = Replace(oldName, ".xlsb", ".xlsx")
    oldName = Replace(oldName, ".xlsm", ".xlsx")
    oldName = Replace(oldName, ")", "(")
    Dim arr As Variant
    arr = Split(oldName, "(")
    Dim newName As String
    If UBound(arr) > 0 Then
        If IsNumeric(arr(UBound(arr))) Then
            arr(UBound(arr)) = arr(UBound(arr)) + 1
            arr(UBound(arr)) = "(" & arr(UBound(arr)) & ")"
            newName = Join(arr, "")
        End If
    End If
    If newName = "" Then
        With CreateObject("Scripting.FileSystemObject")
            newName = .GetBaseName(oldName) & " (1).xlsx"
        End With
    End If
    GetNewName = newName
End Function
 
Function GetSh2(sh1 As Worksheet) As Worksheet
    Dim sh2 As Worksheet
    sh1.Copy
    Set sh2 = ActiveSheet
    sh2.Cells.Clear
    With sh2.PageSetup
        .Orientation = xlPortrait
        .LeftMargin = Application.InchesToPoints(1.96850393700787)
        .RightMargin = Application.InchesToPoints(1.96850393700787)
        .TopMargin = Application.InchesToPoints(1.96850393700787)
        .BottomMargin = Application.InchesToPoints(3.93700787401575)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
    End With
     
    Set GetSh2 = sh2
End Function
 
Sub OutArr(arr As Variant, sh2 As Worksheet)
    'With Workbooks.Add(1)
    With sh2.Parent
        With .Sheets(1)
            With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Cells = arr
            End With
        End With
        .Saved = True
    End With
End Sub
 
Function GetNoEmptyRowArr(arr As Variant, sh1 As Worksheet, sh2 As Worksheet) As Variant
    Dim y As Long
    Dim n As Long
    For y = 3 To UBound(arr, 1)
        n = n + 1 + IsEmpty(arr(y, 1))
    Next
    If n > 0 Then
        Dim brr As Variant
        ReDim brr(1 To n, 1 To UBound(arr, 2))
        Dim x As Integer
        Dim yOZ As Long
        n = 0
        For y = 3 To UBound(arr, 1)
            If Not IsEmpty(arr(y, 1)) Then
                n = n + 1
                For x = 1 To UBound(arr, 2)
                    brr(n, x) = arr(y, x)
                    If x > 4 Then
                        If x < 11 Then
                            If brr(n, x) = "" Then
                                brr(n, x) = "'"
                            End If
                        End If
                    End If
                Next
                 
                If yOZ = 0 Then
                    yOZ = n
                    'brr(yOZ, 11) = 0
                End If
                If IsNumeric(brr(yOZ, 11)) Then
                    If IsNumeric(arr(y, 11)) Then
                        brr(yOZ, 11) = brr(yOZ, 11) - arr(y, 11)
                    End If
                End If
                 
                sh1.Rows(y).Copy sh2.Cells(n, 1)
            End If
            If arr(y, 3) = "Общие затраты:" Then
                If IsNumeric(brr(yOZ, 11)) Then
                    If IsNumeric(arr(y, 10)) Then
                        brr(yOZ, 11) = brr(yOZ, 11) + arr(y, 10)
                    End If
                End If
                yOZ = 0
            End If
        Next
        GetNoEmptyRowArr = brr
    End If
End Function
 
Function GetArr(sh As Worksheet) As Variant
    With sh
        GetArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 3).End(xlUp).Cells(1, 11 - 2))
    End With
End Function
 
182 строки кода, с доработками и исправлениями в соответствии с хотелками, это точно бесплатная ветка?
Изменено: Msi2102 - 24.11.2021 12:40:34
 
Решение может многим пригодится для анализа входящей сметной документации кто помидоры и огурцы заменит нужными словосечатиями
 
Msi2102, +1 )
 
Цитата
New написал:
Msi2102 , +1 )
это не мне, это МатросНаЗебре +182 в карму  :)
 
Цитата
написал:
это точно бесплатная ветка?
Про оплату разговор не заводили.

Цитата
написал:
Решение может многим пригодится
Это вряд ли. Какие-то элементы мозаики может и пригодятся, но маловероятно, что кто-то воспользуется именно в таком виде.  
 
Каждый ТС считает, что его задача нужна всем, а по факту только ему одному. У других либо другие задачи, либо другая форма данных.
 
Как минимум, имея пример реорганизации на какой-то форме есть шанс вникнуть в "элементы мозайки" предложенного кода и применить для своей формы и нужд.
И именно находясь на форуме долгое время и читая его темы, я предполагал что поможет именно Матрос на зебре, а от остальных прям кроме замечаний ничего особо не надеялся увидеть
Изменено: Тимофеев - 24.11.2021 13:50:29
 
Цитата
Тимофеев написал:
есть шанс вникнуть в "элементы мозайки"
А мне одному кажется, что Вы не сами вникали в элементы мозаики, а просили доработать МатросНаЗебре.
Цитата
Тимофеев написал:
я предполагал что поможет именно Матрос на зебре
Поможет или сделает за Вас
Только поймите правильно, я абсолютно не против, того, что Вам так хорошо помогли, просто моё мнение, что выполнение такого рода заданий, должно оплачиваться
Изменено: Msi2102 - 24.11.2021 13:57:43
 
У меня нет такой копилки знаний как у МатросНаЗебре, он помогает людям делится своими наработками - за это ему громадное спасибо. В темах где отвечает он всегда есть фрагменты кода и комментарии к нему, которые могут быть в дальнейшем кому-то полезны. Темы с его ответами всегда читаю и просматриваю независимо от интереса к теме. Чтобы что-то отложилось в голове.
Да в данной теме не только один вопрос обсуждался и решения были предложены, но считаю абсолютно не нужным дробить это. Человек последующий сможет зайти и Мозайкой воспользоваться для своих нужд.
Я постараюсь отблагодарить МатросНаЗебре за предоставленную помощь
Изменено: Тимофеев - 24.11.2021 14:07:28
 
Цитата
Тимофеев написал:
считаю абсолютно не нужным дробить это
Так тут и смысл, в том, что в этой ветке осуществляется помощь, то есть "Я пытался сделать, но не совсем вышло, подскажите как правильнее", поэтому в правилах и прописано один вопрос - одна тема, а у Вас получается "У меня ничего не получилось, сделайте за меня", для такой постановки вопроса, есть раздел РАБОТА.
Цитата
Тимофеев написал:
он помогает людям делится своими наработками - за это ему громадное спасибо.
Он конечно молодец, но мне кажется, что спасибо немного маловато, ведь Вы в дальнейшем будете использовать этот код для своей работы, а следовательно будете получать определенные бонусы, сократите свое рабочее время. А за время потраченное на Вас лишь спасибо
 
спасибо немного маловато - Учту ваше кажется - Данный вопрос обсудим с ним в личной переписке.  
Страницы: 1
Наверх