Страницы: 1
RSS
Перенос актуальных строк из умной таблицы одной книги в другую.
 
Здравствуйте товарищи!
Помогите с написанием макроса, который бы переносил строки из одной умной таблицы из книги "Расчёты", в другую умную таблицу книги "База" по признаку из столбца "Е". Причём без разницы какое там значение за исключением "0" или "".
В файлах показаны состояния таблиц до, и после активации макроса.
Спасибо всем за ранее!!!)
 
Решение.
Скрытый текст
 
Огромное спасибо!!! Работает! Дай бог Тебе здоровья и позитива!)
 
Попробовал этот макрос запустить с таблицей в 85к строк и ..... уже час как выполняется. Может есть решение более производительнее?
 
Код
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
 
Спасибо большое за код, но есть 2 ньюанса.
1) После активации макроса исчезают внутренние границы ячеек в умной таблице доноре и .....формулы исчезают переходя в значение.
2) Выпадает последний столбец из умной таблицы акцепторе.
В первом случае я думаю справлюсь с помощью макрорекордера и смогу вписать код в основной макрос, вот со вторым у меня сложно... хотя наверное тоже через макрорекордер можно решить вопрос. Хочу просто уточнить, если эти события в ущерб скорости действия макроса при работе с большим количеством строк, то можно с этим смириться, если нет, та я самостоятельно попробую исправить. Спасибо ещё раз за макрос!
И ещё одна проблема. Если файл донор закрыть, то макрос переносимые данные удаляет не открыв книгу донор. Если книга должна быть открыта, то лучше чтоб макрос выдавал ошибку. Но мне кажется можно прописать открытие книги как в ранее предложенном варианте.
Изменено: sirius0211 - 30.11.2021 17:24:56
 
Код
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
 
Извиняюсь за поздний комментарий по поводу исчезновения данных во время переноса, если не открыта книга.
 
Ещё раз проверил макрос, работает не просто быстро, а ооочень быстро). Выполняет все задачи на отлично! Единственная загвоздка что макрос не отслеживает корректность переноса данных, т.е. если таблица донор закрыта, данные переноса просто удаляются в некуда. В первом макросе (отдельная большая благодарность товарищу!) этих проблем нет. Таблица донор принимает данные открывшись во время исполнения кода и закрывшись после исполнения.  И запрос на файл донор через окно, тоже довольно приятное решение!). Опять же спасибо всем, за всё!!!!)
 
Так будет проверять, открыта ли база.
Код
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
'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
 
Не пойму что я делаю не так, наверное руки кривые(. И ещё если не сложно, укажи пожалуйста в какой строке редактируется ссылка на столбец, по которому происходит отбор. Я ток понял это тут: If arr(y, 6) = 0 Then  Т.е. этот код гласит: если в ячейке по шестому столбцу в таблице1 равно 0.?
 
А так?
Код
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.?
Всё верно.
 
sirius0211, Вариант.
 
Я уже совсем себе головы сломал и Ваше время бессовестно потратил сверх приличия. Не получилось(
Может так решим задачу:

Это рабочий код
Код
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

К нему в начале добавить этот:
Код
Sub Open_file()      'Макрос открытия файла
    FilePath = Sheets("Лист1").Cells(1, 1) 'Забираем полный путь к файлу из ячейки A1 на листе "Лист1"
    Workbooks.Open Filename:=FilePath  'Открытие файла
End Sub
,
а в конце код, который закрывает книгу донор.
Я пытался их соединить, но не получилось, не хватает знаний, и код на закрытие файла не нашёл.(
 
Изменено: sirius0211 - 01.12.2021 15:21:17
 
skais675, отлично сработало но, в файле "Расчёты" вместо формул после активации макроса, стали значения. Необходимо сохранить в файле "Расчёты" формулы, а в файле база значения. Со скоростью всё отлично, хотя чуть-чуть уступает варианту от Матроса на зебре). 0,5 секунд против 2 секунд. Мне это абсолютно не критично, просто инфа, может кому то будет интересно.)
Прошу у всех извинения, за то, что чисто случайно перепутал понятия донора и акцептора. Возможно это тоже сбило вас при написании кода.
 
Цитата
написал:
Прошу у всех извинения, за то, что чисто случайно перепутал понятия донора и акцептора.
Переставил.
Код
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
 
Доработал с формулами.
Изменено: skais675 - 01.12.2021 17:27:54
 
Ну всё!!!! Всем, кто помогал огромное спасибо!!! Заработало как надо!!!)
Страницы: 1
Наверх