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
|