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
|