Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 129 След.
Аппроксимация полиномом в MS Excel., Сравнение разных способов аппроксимации полиномом. Низкое "качество" аппроксимации встроенной функцией ЛИНЕЙН.
 
Коэффициенты можно найти формулами:
Код
=(СЧЁТ(A1:A3)*СУММПРОИЗВ(A1:A3;B1:B3)-СУММ(A1:A3)*СУММ(B1:B3))/(СЧЁТ(A1:A3)*СУММПРОИЗВ(A1:A3;A1:A3)-СУММ(A1:A3)*СУММ(A1:A3))
=(СУММ(B1:B3)-(СЧЁТ(A1:A3)*СУММПРОИЗВ(A1:A3;B1:B3)-СУММ(A1:A3)*СУММ(B1:B3))/(СЧЁТ(A1:A3)*СУММПРОИЗВ(A1:A3;A1:A3)-СУММ(A1:A3)*СУММ(A1:A3))*СУММ(A1:A3))/СЧЁТ(A1:A3)
И через VBA.
Код
Function МЛИНЕЙН(известные_значения_y As Range, известные_значения_x As Range) As Variant
    Dim xrr As Variant
    Dim yrr As Variant
    xrr = известные_значения_x
    yrr = известные_значения_y
    Dim nn As Long
    nn = известные_значения_y.Cells.Count
    Dim x As Double
    Dim y As Double
    Dim xx As Double
    Dim xy As Double
    
    Dim i As Long
    For i = 1 To nn
        x = x + xrr(i, 1)
        y = y + yrr(i, 1)
        xy = xy + xrr(i, 1) * yrr(i, 1)
        xx = xx + xrr(i, 1) * xrr(i, 1)
    Next
    Dim aa As Double
    Dim bb As Double
    aa = (nn * xy - x * y) / (nn * xx - x * x)
    bb = (y - aa * x) / nn
    
    Dim arr As Variant
    ReDim arr(1 To 2)
    arr(1) = aa
    arr(2) = bb
    
    МЛИНЕЙН = arr
End Function
Изменено: МатросНаЗебре - 03.12.2021 15:02:39
Распределение числовых значений по интервалам
 
Цитата
написал:
если скважина будет под углом
Поделив на косинус угла отклонения от вертикали, получите длину вдоль оси скважины, приходящуюся на горизонт.
Разделить 2 числа в одной ячейке
 
Код
=ПСТР(B2;1;НАЙТИ("/";B2)-1)
=ПСТР(B2;НАЙТИ("/";B2)+1;ДЛСТР(B2))
Код
=ЗНАЧЕН(ПСТР(B2;1;НАЙТИ("./";B2)-1))
=ЗНАЧЕН(ПСТР(B2;НАЙТИ("./";B2)+2;ДЛСТР(B2)))
Изменено: МатросНаЗебре - 02.12.2021 15:10:11
ВПР минимальной даты или Аналог функции МИНЕСЛИ в офисе до 2019
 
Для варианта "*текст*"& формулы примут вид:
Код
=50000-МАКС((ЕСЛИОШИБКА(НАЙТИ($F9;$B$3:$B$11);0)>0)*(ЕСЛИОШИБКА(НАЙТИ(1;$B$3:$B$11);0)>0)*(50000-$C$3:$C$11))
=МАКС((ЕСЛИОШИБКА(НАЙТИ($F9;$B$3:$B$11);0)>0)*(ЕСЛИОШИБКА(НАЙТИ(1;$B$3:$B$11);0)>0)*($C$3:$C$11))
Как я уже писал, это формулы массива. Вводятся через Ctrl+Shift+Enter.
ВПР минимальной даты или Аналог функции МИНЕСЛИ в офисе до 2019
 
Цитата
написал:
данные при сортировке меняются...
Что-то не то делаете, у меня данные при сортировке не меняются.

Цитата
написал:
а при добавлении &"*1*" вообще ахинея
1 уже добавлен в формулы.
Код
...НАЙТИ(1;...
ВПР минимальной даты или Аналог функции МИНЕСЛИ в офисе до 2019
 
Формулы массива
Код
=50000-МАКС((ЛЕВСИМВ($B$3:$B$11;ДЛСТР($F9))=$F9)*(ЕСЛИОШИБКА(НАЙТИ(1;$B$3:$B$11);0)>0)*(50000-$C$3:$C$11))
=МАКС((ЛЕВСИМВ($B$3:$B$11;ДЛСТР($F9))=$F9)*(ЕСЛИОШИБКА(НАЙТИ(1;$B$3:$B$11);0)>0)*($C$3:$C$11))
Автозаполнение новых листов по данным таблицы в первом листе
 
Код
Option Explicit

Sub Сформировать()
    With Sheets(1)
        If .Range("A1").Value <> "Фамилия Имя Отчество" Then
            MsgBox "Выберите книгу с учителями.", vbExclamation
            Exit Sub
        End If
        
        Dim yMax As Long
        yMax = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim xMax As Integer
        xMax = .Cells(1, .Columns.Count).End(xlToLeft).Column
        Dim arrBack As Variant
        arrBack = .Range(.Cells(1, 1), .Cells(yMax, xMax))
        
        Dim arrRow As Variant
        
        Dim y As Long
        For y = 2 To yMax
            If y > 2 Then
                arrRow = .Range(.Cells(y, 1), .Cells(y, xMax))
                .Cells(2, 1).Resize(1, UBound(arrRow, 2)) = arrRow
            End If
            OneTeacherJob
        Next
        .Cells(1, 1).Resize(UBound(arrBack, 1), UBound(arrBack, 2)) = arrBack
    End With
End Sub

Sub OneTeacherJob()
    Application.CalculateFull
    Dim wbBack As Workbook
    Set wbBack = ActiveWorkbook
    If wbBack.Sheets.Count < 2 Then Exit Sub
    wbBack.Sheets(2).Copy
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    With wb.Sheets(1)
        Dim arr As Variant
        arr = .UsedRange
        .UsedRange.Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        Erase arr
        Dim sName As String
        sName = .Range("A18").Value
    End With
    
    Dim sFull As String
    sFull = wbBack.Path & "\" & sName & ".xlsx"
    On Error Resume Next
    Kill sFull
    Err.Clear
    wb.SaveAs Filename:=sFull, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    If Err = 0 Then wb.Close False
    On Error GoTo 0
    wbBack.Activate
End Sub
Подсчет остатка по ФИФО
 
Код
Option Explicit

Sub FIFO()
    FLIFO True
End Sub

Sub LIFO()
    FLIFO False
End Sub

Sub FLIFO(upDown As Boolean)
    Dim tb1 As ListObject
    Set tb1 = Sheets("Покупки").ListObjects("Таблица1")
            
    Dim ar1 As Variant
    ar1 = tb1.DataBodyRange
    
    Dim arO As Variant
    With Sheets("остаток ЦБ")
        arO = .Range(.Cells(1, 3), .Cells(.Rows.Count, 5).End(xlUp))
    End With
    
    Dim yMin As Long
    If upDown Then
        yMin = 1
    Else
        yMin = UBound(ar1, 1)
    End If
    
    Dim yO As Long
    Dim y1 As Long
    Dim d As Double
    For yO = 2 To UBound(arO, 1)
        For y1 = yMin To UBound(ar1, 1) - yMin + 1 Step 1 + 2 * (UBound(ar1, 1) = yMin)
            If arO(yO, 3) = ar1(y1, 2) Then
                d = IIf(arO(yO, 1) < ar1(y1, 3), arO(yO, 1), ar1(y1, 3))
                If d <> 0 Then
                    arO(yO, 1) = arO(yO, 1) - d
                End If
                ar1(y1, 3) = d
            End If
        Next
    Next
    tb1.DataBodyRange = ar1
End Sub
Изменено: МатросНаЗебре - 02.12.2021 09:57:36
Подсчет остатка по ФИФО
 
Код
Option Explicit

Sub FIFO()
    Dim tb1 As ListObject
    Set tb1 = Sheets("Покупки").ListObjects("Таблица1")
            
    Dim ar1 As Variant
    ar1 = tb1.DataBodyRange
    
    Dim arO As Variant
    With Sheets("остаток ЦБ")
        arO = .Range(.Cells(1, 3), .Cells(.Rows.Count, 5).End(xlUp))
    End With
    
    Dim yO As Long
    Dim y1 As Long
    Dim d As Double
    For yO = 2 To UBound(arO, 1)
        For y1 = 1 To UBound(ar1, 1)
            If arO(yO, 3) = ar1(y1, 2) Then
                d = IIf(arO(yO, 1) < ar1(y1, 3), arO(yO, 1), ar1(y1, 3))
                If d = 0 Then
                    Exit For
                Else
                    arO(yO, 1) = arO(yO, 1) - d
                    ar1(y1, 3) = ar1(y1, 3) - d
                End If
            End If
        Next
    Next
    tb1.DataBodyRange = ar1
End Sub
Перенос актуальных строк из умной таблицы одной книги в другую.
 
Цитата
написал:
Прошу у всех извинения, за то, что чисто случайно перепутал понятия донора и акцептора.
Переставил.
Код
Option Explicit
'v6
Const FILENAME_CALC = "Расчёты.xlsx"
Const FILENAME_BASE = "База.xlsx"

Sub MoveToBaseNonZeroRowsByDialog()
    Dim wbR As Workbook
    On Error Resume Next
    Set wbR = Workbooks(FILENAME_CALC)
    On Error GoTo 0
    If wbR Is Nothing Then
        MsgBox "Откройте файл " & FILENAME_CALC, vbExclamation
    Else
        Dim wbB As Workbook
        Set wbB = ShowFileDialog("Файл База")
        If Not wbB Is Nothing Then
            MoveToBaseNonZeroRows wbR, wbB
            Application.DisplayAlerts = False
            wbB.Close True
            Application.DisplayAlerts = True
        End If
    End If
End Sub

Function ShowFileDialog(sTitle) 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 = sTitle 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
'        .Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Path & "\" & FILENAME_BASE 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        Dim wb As Workbook
        
        For lf = 1 To .SelectedItems.Count
            x = .SelectedItems(lf) 'считываем полный путь к файлу
            On Error Resume Next
            Set wb = Workbooks(CreateObject("Scripting.FileSystemObject").GetFileName(x))
            On Error GoTo 0
            If wb Is Nothing Then
                Set wb = Workbooks.Open(x)  'открытие книги
            End If
            'можно также без х
            'Workbooks.Open .SelectedItems(lf)
        Next
        Set ShowFileDialog = wb
    End With
End Function

Sub MoveToBaseNonZeroRows(wbR As Workbook, wbB As Workbook)
'    On Error Resume Next
'    Set wbR = Workbooks("Расчёты.xlsx")
'    On Error GoTo 0
    If Not wbR Is Nothing Then
        Dim tb1 As ListObject
        On Error Resume Next
        Set tb1 = wbR.Sheets(1).ListObjects("Таблица1")
        On Error GoTo 0
        If Not tb1 Is Nothing Then
            Dim tb2 As ListObject
            On Error Resume Next
            Set tb2 = wbB.Sheets(1).ListObjects("Таблица1")
            On Error GoTo 0
            If Not tb2 Is Nothing Then
                Dim arr As Variant
                arr = tb1.DataBodyRange
                
                Dim brr As Variant
                Dim crr As Variant
                ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
                crr = brr
                
                Dim y As Long
                Dim u As Long
                Dim o As Long
                Dim x As Integer
                
                Dim frr As Variant
                ReDim frr(1 To 1, 1 To UBound(arr, 2))
                For x = 1 To UBound(arr, 2)
                    With tb1.DataBodyRange.Cells(1, x)
                        If .HasFormula Then
                            frr(1, x) = .Formula
                        End If
                    End With
                Next
                
                For y = 1 To UBound(arr, 1)
                    If arr(y, 6) = 0 Then
                        u = u + 1
                        For x = 1 To UBound(arr, 2)
                            brr(u, x) = arr(y, x)
                        Next
                    Else
                        o = o + 1
                        For x = 1 To UBound(arr, 2)
                            crr(o, x) = arr(y, x)
                        Next
                    End If
                Next
                If u > 0 Then
                    Dim bbr As Variant
                    ReDim bbr(1 To u, 1 To UBound(brr, 2))
                    For y = 1 To UBound(bbr, 1)
                        For x = 1 To UBound(bbr, 2)
                            bbr(y, x) = brr(y, x)
                        Next
                    Next
                    Erase brr
                    
    '                tb1.DataBodyRange.Clear
                    tb1.Resize tb1.Range.Cells(1, 1).Resize(u + 1, UBound(bbr, 2))
                    tb1.DataBodyRange.Value = bbr
                    
                    If UBound(arr, 1) > u Then
                        tb1.Range.Cells(u + 2, 1).Resize(UBound(arr, 1) - u, UBound(bbr, 2)).Clear
                    End If
                    Erase bbr
                    For x = 1 To UBound(frr, 2)
                        If Not IsEmpty(frr(1, x)) Then tb1.DataBodyRange.Columns(x).Formula = frr(1, x)
                    Next
                    Erase frr
                End If
            End If
            If o > 0 Then
                Dim ccr As Variant
                ReDim ccr(1 To o, 1 To UBound(crr, 2))
                For y = 1 To UBound(ccr, 1)
                    For x = 1 To UBound(ccr, 2)
                        ccr(y, x) = crr(y, x)
                    Next
                Next
                Erase crr
'                Dim tb2 As ListObject
'                On Error Resume Next
'                Set tb2 = Workbooks("База.xlsx").Sheets(1).ListObjects("Таблица1")
'                On Error GoTo 0
                If Not tb2 Is Nothing Then
                    tb2.Resize tb2.Range.Cells(1, 1).Resize(tb2.Range.Rows.Count + o, tb2.Range.Columns.Count)
                    tb2.DataBodyRange.Cells(tb2.DataBodyRange.Rows.Count + 1 - UBound(ccr, 1), 1).Resize(UBound(ccr, 1), UBound(ccr, 2)).Value = ccr
                End If
                Erase ccr
            End If
        End If
    End If
End Sub
Перенос актуальных строк из умной таблицы одной книги в другую.
 
А так?
Код
Option Explicit
'v5
Sub MoveToBaseNonZeroRowsByDialog()
    Dim wbB As Workbook
    'Set wbB = ShowFileDialog("Файл База")
    On Error Resume Next
    Set wbB = Workbooks("База.xlsx")
    On Error GoTo 0
    If Not wbB Is Nothing Then
        Dim wbR As Workbook
        Set wbR = ShowFileDialog("Файл Расчёты")
        If Not wbR Is Nothing Then
            MoveToBaseNonZeroRows wbR, wbB
            Application.DisplayAlerts = False
            wbR.Close True
            Application.DisplayAlerts = True
        End If
    End If
End Sub

Function ShowFileDialog(sTitle) 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 = sTitle 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
'        .Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Path & "\Расчёты" 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        Dim wb As Workbook
        
        For lf = 1 To .SelectedItems.Count
            x = .SelectedItems(lf) 'считываем полный путь к файлу
            On Error Resume Next
            Set wb = Workbooks(CreateObject("Scripting.FileSystemObject").GetFileName(x))
            On Error GoTo 0
            If wb Is Nothing Then
                Set wb = Workbooks.Open(x)  'открытие книги
            End If
            'можно также без х
            'Workbooks.Open .SelectedItems(lf)
        Next
        Set ShowFileDialog = wb
    End With
End Function

Sub MoveToBaseNonZeroRows(wbR As Workbook, wbB As Workbook)
'    On Error Resume Next
'    Set wbR = Workbooks("Расчёты.xlsx")
'    On Error GoTo 0
    If Not wbR Is Nothing Then
        Dim tb1 As ListObject
        On Error Resume Next
        Set tb1 = wbR.Sheets(1).ListObjects("Таблица1")
        On Error GoTo 0
        If Not tb1 Is Nothing Then
            Dim tb2 As ListObject
            On Error Resume Next
            Set tb2 = wbB.Sheets(1).ListObjects("Таблица1")
            On Error GoTo 0
            If Not tb2 Is Nothing Then
                Dim arr As Variant
                arr = tb1.DataBodyRange
                
                Dim brr As Variant
                Dim crr As Variant
                ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
                crr = brr
                
                Dim y As Long
                Dim u As Long
                Dim o As Long
                Dim x As Integer
                
                Dim frr As Variant
                ReDim frr(1 To 1, 1 To UBound(arr, 2))
                For x = 1 To UBound(arr, 2)
                    With tb1.DataBodyRange.Cells(1, x)
                        If .HasFormula Then
                            frr(1, x) = .Formula
                        End If
                    End With
                Next
                
                For y = 1 To UBound(arr, 1)
                    If arr(y, 6) = 0 Then
                        u = u + 1
                        For x = 1 To UBound(arr, 2)
                            brr(u, x) = arr(y, x)
                        Next
                    Else
                        o = o + 1
                        For x = 1 To UBound(arr, 2)
                            crr(o, x) = arr(y, x)
                        Next
                    End If
                Next
                If u > 0 Then
                    Dim bbr As Variant
                    ReDim bbr(1 To u, 1 To UBound(brr, 2))
                    For y = 1 To UBound(bbr, 1)
                        For x = 1 To UBound(bbr, 2)
                            bbr(y, x) = brr(y, x)
                        Next
                    Next
                    Erase brr
                    
    '                tb1.DataBodyRange.Clear
                    tb1.Resize tb1.Range.Cells(1, 1).Resize(u + 1, UBound(bbr, 2))
                    tb1.DataBodyRange.Value = bbr
                    
                    If UBound(arr, 1) > u Then
                        tb1.Range.Cells(u + 2, 1).Resize(UBound(arr, 1) - u, UBound(bbr, 2)).Clear
                    End If
                    Erase bbr
                    For x = 1 To UBound(frr, 2)
                        If Not IsEmpty(frr(1, x)) Then tb1.DataBodyRange.Columns(x).Formula = frr(1, x)
                    Next
                    Erase frr
                End If
            End If
            If o > 0 Then
                Dim ccr As Variant
                ReDim ccr(1 To o, 1 To UBound(crr, 2))
                For y = 1 To UBound(ccr, 1)
                    For x = 1 To UBound(ccr, 2)
                        ccr(y, x) = crr(y, x)
                    Next
                Next
                Erase crr
'                Dim tb2 As ListObject
'                On Error Resume Next
'                Set tb2 = Workbooks("База.xlsx").Sheets(1).ListObjects("Таблица1")
'                On Error GoTo 0
                If Not tb2 Is Nothing Then
                    tb2.Resize tb2.Range.Cells(1, 1).Resize(tb2.Range.Rows.Count + o, tb2.Range.Columns.Count)
                    tb2.DataBodyRange.Cells(tb2.DataBodyRange.Rows.Count + 1 - UBound(ccr, 1), 1).Resize(UBound(ccr, 1), UBound(ccr, 2)).Value = ccr
                End If
                Erase ccr
            End If
        End If
    End If
End Sub

Цитата
написал:
Я ток понял это тут: If arr(y, 6) = 0 Then  Т.е. этот код гласит: если в ячейке по шестому столбцу в таблице1 равно 0.?
Всё верно.
Перенос актуальных строк из умной таблицы одной книги в другую.
 
Файл донор выбирается через диалоговое окно, потом закрывается.
Код
Option Explicit
'v4
Sub MoveToBaseNonZeroRowsByDialog()
    Dim wbB As Workbook
    'Set wbB = ShowFileDialog("Файл База")
    On Error Resume Next
    Set wbB = Workbooks("База.xlsx")
    On Error GoTo 0
    If Not wbB Is Nothing Then
        Dim wbR As Workbook
        Set wbR = ShowFileDialog("Файл Расчёты")
        If Not wbR Is Nothing Then
            MoveToBaseNonZeroRows wbR, wbB
            Application.DisplayAlerts = False
            wbR.Close True
            Application.DisplayAlerts = True
        End If
    End If
End Sub

Function ShowFileDialog(sTitle) 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 = sTitle 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
'        .Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Path 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            x = .SelectedItems(lf) 'считываем полный путь к файлу
            Set ShowFileDialog = Workbooks.Open(x)  'открытие книги
            'можно также без х
            'Workbooks.Open .SelectedItems(lf)
        Next
    End With
End Function

Sub MoveToBaseNonZeroRows(wbR As Workbook, wbB As Workbook)
'    On Error Resume Next
'    Set wbR = Workbooks("Расчёты.xlsx")
'    On Error GoTo 0
    If Not wbR Is Nothing Then
        Dim tb1 As ListObject
        On Error Resume Next
        Set tb1 = wbR.Sheets(1).ListObjects("Таблица1")
        On Error GoTo 0
        If Not tb1 Is Nothing Then
            Dim tb2 As ListObject
            On Error Resume Next
            Set tb2 = wbB.Sheets(1).ListObjects("Таблица1")
            On Error GoTo 0
            If Not tb2 Is Nothing Then
                Dim arr As Variant
                arr = tb1.DataBodyRange
                
                Dim brr As Variant
                Dim crr As Variant
                ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
                crr = brr
                
                Dim y As Long
                Dim u As Long
                Dim o As Long
                Dim x As Integer
                
                Dim frr As Variant
                ReDim frr(1 To 1, 1 To UBound(arr, 2))
                For x = 1 To UBound(arr, 2)
                    With tb1.DataBodyRange.Cells(1, x)
                        If .HasFormula Then
                            frr(1, x) = .Formula
                        End If
                    End With
                Next
                
                For y = 1 To UBound(arr, 1)
                    If arr(y, 6) = 0 Then
                        u = u + 1
                        For x = 1 To UBound(arr, 2)
                            brr(u, x) = arr(y, x)
                        Next
                    Else
                        o = o + 1
                        For x = 1 To UBound(arr, 2)
                            crr(o, x) = arr(y, x)
                        Next
                    End If
                Next
                If u > 0 Then
                    Dim bbr As Variant
                    ReDim bbr(1 To u, 1 To UBound(brr, 2))
                    For y = 1 To UBound(bbr, 1)
                        For x = 1 To UBound(bbr, 2)
                            bbr(y, x) = brr(y, x)
                        Next
                    Next
                    Erase brr
                    
    '                tb1.DataBodyRange.Clear
                    tb1.Resize tb1.Range.Cells(1, 1).Resize(u + 1, UBound(bbr, 2))
                    tb1.DataBodyRange.Value = bbr
                    
                    If UBound(arr, 1) > u Then
                        tb1.Range.Cells(u + 2, 1).Resize(UBound(arr, 1) - u, UBound(bbr, 2)).Clear
                    End If
                    Erase bbr
                    For x = 1 To UBound(frr, 2)
                        If Not IsEmpty(frr(1, x)) Then tb1.DataBodyRange.Columns(x).Formula = frr(1, x)
                    Next
                    Erase frr
                End If
            End If
            If o > 0 Then
                Dim ccr As Variant
                ReDim ccr(1 To o, 1 To UBound(crr, 2))
                For y = 1 To UBound(ccr, 1)
                    For x = 1 To UBound(ccr, 2)
                        ccr(y, x) = crr(y, x)
                    Next
                Next
                Erase crr
'                Dim tb2 As ListObject
'                On Error Resume Next
'                Set tb2 = Workbooks("База.xlsx").Sheets(1).ListObjects("Таблица1")
'                On Error GoTo 0
                If Not tb2 Is Nothing Then
                    tb2.Resize tb2.Range.Cells(1, 1).Resize(tb2.Range.Rows.Count + o, tb2.Range.Columns.Count)
                    tb2.DataBodyRange.Cells(tb2.DataBodyRange.Rows.Count + 1 - UBound(ccr, 1), 1).Resize(UBound(ccr, 1), UBound(ccr, 2)).Value = ccr
                End If
                Erase ccr
            End If
        End If
    End If
End Sub
Перенос актуальных строк из умной таблицы одной книги в другую.
 
Так будет проверять, открыта ли база.
Код
Option Explicit
'v3
Sub MoveToBaseNonZeroRows()
    Dim wbR As Workbook
    On Error Resume Next
    Set wbR = Workbooks("Расчёты.xlsx")
    On Error GoTo 0
    If Not wbR Is Nothing Then
        Dim tb1 As ListObject
        On Error Resume Next
        Set tb1 = wbR.Sheets(1).ListObjects("Таблица1")
        On Error GoTo 0
        If Not tb1 Is Nothing Then
            Dim tb2 As ListObject
            On Error Resume Next
            Set tb2 = Workbooks("База.xlsx").Sheets(1).ListObjects("Таблица1")
            On Error GoTo 0
            If Not tb2 Is Nothing Then
                Dim arr As Variant
                arr = tb1.DataBodyRange
                
                Dim brr As Variant
                Dim crr As Variant
                ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
                crr = brr
                
                Dim y As Long
                Dim u As Long
                Dim o As Long
                Dim x As Integer
                
                Dim frr As Variant
                ReDim frr(1 To 1, 1 To UBound(arr, 2))
                For x = 1 To UBound(arr, 2)
                    With tb1.DataBodyRange.Cells(1, x)
                        If .HasFormula Then
                            frr(1, x) = .Formula
                        End If
                    End With
                Next
                
                For y = 1 To UBound(arr, 1)
                    If arr(y, 6) = 0 Then
                        u = u + 1
                        For x = 1 To UBound(arr, 2)
                            brr(u, x) = arr(y, x)
                        Next
                    Else
                        o = o + 1
                        For x = 1 To UBound(arr, 2)
                            crr(o, x) = arr(y, x)
                        Next
                    End If
                Next
                If u > 0 Then
                    Dim bbr As Variant
                    ReDim bbr(1 To u, 1 To UBound(brr, 2))
                    For y = 1 To UBound(bbr, 1)
                        For x = 1 To UBound(bbr, 2)
                            bbr(y, x) = brr(y, x)
                        Next
                    Next
                    Erase brr
                    
    '                tb1.DataBodyRange.Clear
                    tb1.Resize tb1.Range.Cells(1, 1).Resize(u + 1, UBound(bbr, 2))
                    tb1.DataBodyRange.Value = bbr
                    
                    tb1.Range.Cells(u + 2, 1).Resize(UBound(arr, 1) - u, UBound(bbr, 2)).Clear
                    Erase bbr
                    For x = 1 To UBound(frr, 2)
                        If Not IsEmpty(frr(1, x)) Then tb1.DataBodyRange.Columns(x).Formula = frr(1, x)
                    Next
                    Erase frr
                End If
            End If
            If o > 0 Then
                Dim ccr As Variant
                ReDim ccr(1 To o, 1 To UBound(crr, 2))
                For y = 1 To UBound(ccr, 1)
                    For x = 1 To UBound(ccr, 2)
                        ccr(y, x) = crr(y, x)
                    Next
                Next
                Erase crr
'                Dim tb2 As ListObject
'                On Error Resume Next
'                Set tb2 = Workbooks("База.xlsx").Sheets(1).ListObjects("Таблица1")
'                On Error GoTo 0
                If Not tb2 Is Nothing Then
                    tb2.Resize tb2.Range.Cells(1, 1).Resize(tb2.Range.Rows.Count + o, tb2.Range.Columns.Count)
                    tb2.DataBodyRange.Cells(tb2.DataBodyRange.Rows.Count + 1 - UBound(ccr, 1), 1).Resize(UBound(ccr, 1), UBound(ccr, 2)).Value = ccr
                End If
                Erase ccr
            End If
        End If
    End If
End Sub
Перенос актуальных строк из умной таблицы одной книги в другую.
 
Код
Option Explicit
'v2
Sub MoveToBaseNonZeroRows()
    Dim wbR As Workbook
    On Error Resume Next
    Set wbR = Workbooks("Расчёты.xlsx")
    On Error GoTo 0
    If Not wbR Is Nothing Then
        Dim tb1 As ListObject
        On Error Resume Next
        Set tb1 = wbR.Sheets(1).ListObjects("Таблица1")
        On Error GoTo 0
        If Not tb1 Is Nothing Then
            Dim arr As Variant
            arr = tb1.DataBodyRange
            
            Dim brr As Variant
            Dim crr As Variant
            ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
            crr = brr
            
            Dim y As Long
            Dim u As Long
            Dim o As Long
            Dim x As Integer
            
            Dim frr As Variant
            ReDim frr(1 To 1, 1 To UBound(arr, 2))
            For x = 1 To UBound(arr, 2)
                With tb1.DataBodyRange.Cells(1, x)
                    If .HasFormula Then
                        frr(1, x) = .Formula
                    End If
                End With
            Next
            
            For y = 1 To UBound(arr, 1)
                If arr(y, 6) = 0 Then
                    u = u + 1
                    For x = 1 To UBound(arr, 2)
                        brr(u, x) = arr(y, x)
                    Next
                Else
                    o = o + 1
                    For x = 1 To UBound(arr, 2)
                        crr(o, x) = arr(y, x)
                    Next
                End If
            Next
            If u > 0 Then
                Dim bbr As Variant
                ReDim bbr(1 To u, 1 To UBound(brr, 2))
                For y = 1 To UBound(bbr, 1)
                    For x = 1 To UBound(bbr, 2)
                        bbr(y, x) = brr(y, x)
                    Next
                Next
                Erase brr
                
'                tb1.DataBodyRange.Clear
                tb1.Resize tb1.Range.Cells(1, 1).Resize(u + 1, UBound(bbr, 2))
                tb1.DataBodyRange.Value = bbr
                
                tb1.Range.Cells(u + 2, 1).Resize(UBound(arr, 1) - u, UBound(bbr, 2)).Clear
                Erase bbr
                For x = 1 To UBound(frr, 2)
                    If Not IsEmpty(frr(1, x)) Then tb1.DataBodyRange.Columns(x).Formula = frr(1, x)
                Next
                Erase frr
            End If
            If o > 0 Then
                Dim ccr As Variant
                ReDim ccr(1 To o, 1 To UBound(crr, 2))
                For y = 1 To UBound(ccr, 1)
                    For x = 1 To UBound(ccr, 2)
                        ccr(y, x) = crr(y, x)
                    Next
                Next
                Erase crr
                Dim tb2 As ListObject
                On Error Resume Next
                Set tb2 = Workbooks("База.xlsx").Sheets(1).ListObjects("Таблица1")
                On Error GoTo 0
                If Not tb2 Is Nothing Then
                    tb2.Resize tb2.Range.Cells(1, 1).Resize(tb2.Range.Rows.Count + o, tb2.Range.Columns.Count)
                    tb2.DataBodyRange.Cells(tb2.DataBodyRange.Rows.Count + 1 - UBound(ccr, 1), 1).Resize(UBound(ccr, 1), UBound(ccr, 2)).Value = ccr
                End If
                Erase ccr
            End If
        End If
    End If
End Sub
Цена старая при наличии остатка на складе. То, что выше складских остатков - по новой цене
 
Формула составлена из расчёта "один столбец - одна формула". То же самое, только текстом.
Код
=МАКС(0;МИН(G23;G23+$F23-СУММ($G23:G23)))&" по "&$B23&" + "&МАКС(0;МИН(G23;(СУММ($G23:G23)-$F23)))&" по "&$C23
Цена старая при наличии остатка на складе. То, что выше складских остатков - по новой цене
 
Достаточно на складе - старая цена.
Нет на складе ни одной шутки - новая цена.
Есть на складе, но недостаточно для месячной потребности - средневзвешенная цена.
Код
=(МАКС(0;МИН(G23;G23+$F23-СУММ($G23:G23)))*$B23+МАКС(0;МИН(G23;(СУММ($G23:G23)-$F23)))*$C23)/G23
Перенос актуальных строк из умной таблицы одной книги в другую.
 
Код
Option Explicit

Sub MoveToBaseNonZeroRows()
    Dim wbR As Workbook
    On Error Resume Next
    Set wbR = Workbooks("Расчёты.xlsx")
    On Error GoTo 0
    If Not wbR Is Nothing Then
        Dim tb1 As ListObject
        On Error Resume Next
        Set tb1 = wbR.Sheets(1).ListObjects("Таблица1")
        On Error GoTo 0
        If Not tb1 Is Nothing Then
            Dim arr As Variant
            arr = tb1.DataBodyRange
            
            Dim brr As Variant
            Dim crr As Variant
            ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
            crr = brr
            
            Dim y As Long
            Dim u As Long
            Dim o As Long
            Dim x As Integer
            For y = 1 To UBound(arr, 1)
                If arr(y, 6) = 0 Then
                    u = u + 1
                    For x = 1 To UBound(arr, 2)
                        brr(u, x) = arr(y, x)
                    Next
                Else
                    o = o + 1
                    For x = 1 To UBound(arr, 2)
                        crr(o, x) = arr(y, x)
                    Next
                End If
            Next
            If u > 0 Then
                Dim bbr As Variant
                ReDim bbr(1 To u, 1 To UBound(brr, 2))
                For y = 1 To UBound(bbr, 1)
                    For x = 1 To UBound(bbr, 2)
                        bbr(y, x) = brr(y, x)
                    Next
                Next
                Erase brr
                tb1.DataBodyRange.Clear
                tb1.Resize tb1.Range.Cells(1, 1).Resize(u + 1, UBound(bbr, 2))
                tb1.DataBodyRange.Value = bbr
                Erase bbr
            End If
            If o > 0 Then
                Dim ccr As Variant
                ReDim ccr(1 To o, 1 To UBound(crr, 2))
                For y = 1 To UBound(ccr, 1)
                    For x = 1 To UBound(ccr, 2)
                        ccr(y, x) = crr(y, x)
                    Next
                Next
                Erase crr
                Dim tb2 As ListObject
                On Error Resume Next
                Set tb2 = Workbooks("База.xlsx").Sheets(1).ListObjects("Таблица1")
                On Error GoTo 0
                If Not tb2 Is Nothing Then
                    tb2.Resize tb2.Range.Cells(1, 1).Resize(tb2.Range.Rows.Count + o, UBound(ccr, 2))
                    tb2.DataBodyRange.Cells(tb2.DataBodyRange.Rows.Count + 1 - UBound(ccr, 1), 1).Resize(UBound(ccr, 1), UBound(ccr, 2)).Value = ccr
                End If
                Erase ccr
            End If
        End If
    End If
End Sub
Автоматические заполнение таблицы при вводе одного значения.
 
Достаточно простой способ - сделать шаблон для каждой мощности.
Вариант чуть посложнее - шаблон один, после заполнения мощности, срабатывает макрос, который тянет из заранее заполненных таблиц требуемые строки. Этот вариант, также требует предварительного заполнения таблиц.
Выделение столбцов по заданным параметрам и выведение их в соседний лист
 
Выделите диапазон, запустите макрос.
Код
Option Explicit

Sub aaa()
    Dim r As Range
    Set r = Selection
    Dim arr As Variant
    arr = r
    Dim brr As Variant
    brr = Range(Cells(2, r.Column), Cells(r.Row - 1, r.Column))
    Dim crr As Variant
    crr = Range(Cells(r.Row + r.Rows.Count, r.Column), Cells(Rows.Count, r.Column).End(xlUp))
    
    With Workbooks.Add(1)
        With .Sheets(1)
            With .Cells(1, 1).Resize(UBound(arr, 1), 1)
                .Value = arr
            End With
            With .Cells(1, 2).Resize(UBound(brr, 1), 1)
                .Value = brr
            End With
            With .Cells(1 + UBound(brr, 1), 2).Resize(UBound(crr, 1), 1)
                .Value = crr
            End With
            
            Cells.FormatConditions.Delete
            ActiveSheet.UsedRange.Select
            Selection.FormatConditions.AddUniqueValues
            Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
            Selection.FormatConditions(1).DupeUnique = xlUnique
            With Selection.FormatConditions(1).Font
                .Color = -16383844
                .TintAndShade = 0
            End With
            With Selection.FormatConditions(1).Interior
                .PatternColorIndex = xlAutomatic
                .Color = 13551615
                .TintAndShade = 0
            End With
            Selection.FormatConditions(1).StopIfTrue = False
        End With
    End With
End Sub

Изменено: МатросНаЗебре - 30.11.2021 14:12:17
Посчитать итоговую оценку, по определенным правилам
 
Код
=ЕСЛИ((СЧЁТЕСЛИМН(C4:E4;5)>=СЧЁТЗ(C4:E4)/2)*(СЧЁТЕСЛИМН(C4:E4;"<4")=0);"отлично";ЕСЛИ((СЧЁТЕСЛИМН(C4:E4;">=4")>=СЧЁТЗ(C4:E4)/2)*(СЧЁТЕСЛИМН(C4:E4;"<3")=0);"хорошо";ЕСЛИ((СЧЁТЕСЛИМН(C4:E4;2)=1);"удовлетворительно";"неудовлетворительно")))
Настроить расположение окон в конструкторе VBA Excel
 
Предположу, что речь про это.
Код
Windows Registry Editor Version 5.00
[HKEY_CURRENT_USER\Software\Microsoft\VBA\6.0\Common]
"Dock"=hex:
[HKEY_CURRENT_USER\Software\Microsoft\VBA\7.0\Common]
"Dock"=hex:
[HKEY_CURRENT_USER\Software\Microsoft\VBA\7.1\Common]
"Dock"=hex:
извлечение второго слова из ячейки в новую ячейку того же столбца
 
Выделите диапазон.
Код
Sub Извлечь()
    Dim r As Range
    Set r = Selection
    Dim arr As Variant
    If r.Cells.Count = 1 Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = r.Cells(1).Value
    Else
        arr = r
    End If
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 1))
    
    Dim y As Long
    Dim u As Long
    Dim v As Variant
    Dim crr As Variant
    For y = 1 To UBound(arr, 1)
        If arr(y, 1) <> "" Then
            crr = Split(arr(y, 1), " ")
            If Not IsEmpty(crr) Then
                If UBound(crr) > 0 Then
                    ReDim Preserve brr(1 To UBound(brr) + UBound(crr))
                End If
                For Each v In crr
                    u = u + 1
                    brr(u) = Trim(v)
                Next
            End If
        End If
    Next
    
    Set r = r.Cells(1, 1).Resize(UBound(brr), 1)
    r = Application.Transpose(brr)
    
    With r.Parent.Sort
        .SortFields.Clear
        .SortFields.Add Key:=r, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        .SetRange r
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
Изменено: МатросНаЗебре - 29.11.2021 17:32:14
Скрытие и отоброжение листов макросом
 
Сделайте это не с массивом, а переберите в цикле.
Заполнение умной таблицы через ввод данных на другом листе
 
Судя по падежам, с формулировкой названия будут сложности )
Вариант названия темы
Заполнение умной таблицы через ввод данных на другом листе
Заполнение умной таблицы через ввод данных на другом листе
 
Код
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        Select Case Target.Address(0, 0)
        Case "C2", "C6"
            If Range("C2").Value <> "" Then
                If Range("C6").Value <> "" Then
                    MoveData
                    Application.EnableEvents = False
                    Range("C2").MergeArea.ClearContents
                    Range("C6").MergeArea.ClearContents
                    Application.EnableEvents = True
                End If
            End If
        End Select
    End If
End Sub

Private Sub MoveData()
    With Sheets("Лист2")
        With .ListObjects(1).DataBodyRange
            With .Rows(.Rows.Count - (.Cells(.Rows.Count, 2).Value <> ""))
                .Cells(1, 2).Value = Range("C2").Value
                .Cells(1, 3).Value = Range("C6").Value
                If .Cells(1, 1).Value = "" Then
                    If IsNumeric(.Cells(1, 1).Offset(-1, 0).Value) Then
                        .Cells(1, 1).Value = .Cells(1, 1).Offset(-1, 0).Value + 1
                    Else
                        .Cells(1, 1).Value = 1
                    End If
                End If
            End With
        End With
    End With
End Sub
Фильтр таблиц с разных листов на третий по условию
 
Код
Option Explicit

Sub ФильтрТаблиц()
    Dim ar1 As Variant
    ar1 = Sheets("Лист1").Range("A1:B10")
    
    Dim ar2 As Variant
    ar2 = Sheets("Лист2").Range("A1:C10")
    
    Dim dic As Object
    Set dic = GetDic(ar1)
    Erase ar1
    
    Dim arr As Variant
    arr = GetArrResult(dic, ar2)
    
    PrintArr arr
End Sub

Sub PrintArr(arr As Variant)
    With Workbooks.Add(1)
        With .Sheets(1).Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
            .Columns(1).NumberFormat = "@"
            .Value = arr
        End With
        .Saved = True
    End With
End Sub

Function GetArrResult(dic, arr) As Variant
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    Dim y As Long
    Dim u As Long
    Dim x As Integer
    For x = 1 To UBound(arr, 2)
        brr(1, x) = arr(1, x)
    Next
    u = 1
    For y = 2 To UBound(arr, 1)
        If dic.Exists(arr(y, 1)) Then
            u = u + 1
            For x = 1 To UBound(arr, 2)
                brr(u, x) = arr(y, x)
            Next
        End If
    Next
    Dim crr As Variant
    ReDim crr(1 To u, 1 To UBound(brr, 2))
    For y = 1 To UBound(crr, 1)
        For x = 1 To UBound(crr, 2)
            crr(y, x) = brr(y, x)
        Next
    Next
    GetArrResult = crr
End Function

Function GetDic(arr As Variant) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim y As Long
    For y = 2 To UBound(arr, 1)
        If arr(y, 2) Then dic.Item(arr(y, 1)) = 0
    Next
    Set GetDic = dic
End Function
формирование сводной таблицы, Формирование таблиц из Отчета Excel
 
Пишу в личку.
Сделал.
Оплату получил.
Изменено: МатросНаЗебре - 25.11.2021 12:30:27
Извлечь из таблицы только строки со стоимостью работ при наличии подчиненных строк
 
Цитата
написал:
это точно бесплатная ветка?
Про оплату разговор не заводили.

Цитата
написал:
Решение может многим пригодится
Это вряд ли. Какие-то элементы мозаики может и пригодятся, но маловероятно, что кто-то воспользуется именно в таком виде.  
Извлечь из таблицы только строки со стоимостью работ при наличии подчиненных строк
 
С сохранением файла с индексом.
Код
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
Извлечь из таблицы только строки со стоимостью работ при наличии подчиненных строк
 
С диалогами.
Файл из #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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 129 След.
Наверх