Option Explicit
Private colTargetArrays As Collection
Private ARR_FIELDS As Variant
Sub Неликвиды()
Dim aFiles As Variant
aFiles = ShowFileDialog()
If IsEmpty(aFiles) Then Exit Sub
Set colTargetArrays = New Collection
ARR_FIELDS = Array("дней", "Код товара", "Товар")
Application.ScreenUpdating = False
Dim Application_Calculation As XlCalculation
Application_Calculation = Application.Calculation
Application.Calculation = xlCalculationManual
CloseEmptyWb
Dim vFile As Variant, wbSource As Workbook
For Each vFile In aFiles
Set wbSource = Workbooks.Open(vFile, False, True)
GetDataFromWorkbook wbSource
wbSource.Close False
Next
If colTargetArrays.Count = 0 Then Exit Sub
PrintColTargetArrays
Application.Calculation = Application_Calculation
Application.ScreenUpdating = True
End Sub
Private Sub PrintColTargetArrays()
Dim vv As Variant, arr As Variant, yt As Long, ys As Long, xs As Long
For Each vv In colTargetArrays
arr = vv
yt = yt + UBound(arr(0), 1)
Next
Dim aTarg As Variant
ReDim aTarg(1 To yt, 1 To UBound(arr) + 2)
yt = 0
For Each vv In colTargetArrays
arr = vv
For ys = LBound(arr(0)) To UBound(arr(0))
yt = yt + 1
For xs = LBound(arr) To UBound(arr)
aTarg(yt, xs + 1) = arr(xs)(ys, 1)
Next
aTarg(yt, 4) = "[Код товара] = " & aTarg(yt, 2) & "ИЛИ"
Next
Next
Set colTargetArrays = Nothing
PrintColTargetArray aTarg
End Sub
Private Sub PrintColTargetArray(arr As Variant)
With Workbooks.Add(1)
With .Worksheets(1)
With .Cells(1, 1).Resize(, UBound(ARR_FIELDS) + 1)
.Value = ARR_FIELDS
.Cells(1, .Columns.Count + 1).Value = "КОДЫ ИТОГ"
With .Cells(1, 1).Resize(1, UBound(ARR_FIELDS) + 2)
.Font.Bold = True
End With
.HorizontalAlignment = xlCenter
Dim vBorder As Variant
For Each vBorder In Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight, xlInsideVertical, xlInsideHorizontal)
With .Cells(1, 1).Resize(UBound(arr, 1) + 1, UBound(arr, 2)).Borders(vBorder)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Next
With .Cells(2, 1).Resize(UBound(arr, 1), UBound(arr, 2))
.Value = arr
.EntireColumn.AutoFit
End With
End With
End With
End With
End Sub
Private Sub GetDataFromWorkbook(wbSource As Workbook)
Dim sh As Worksheet
For Each sh In wbSource.Worksheets
GetDataFromWorkbsheet sh
Next
End Sub
Private Sub GetDataFromWorkbsheet(shSource As Worksheet)
Dim tb As ListObject
On Error Resume Next
Set tb = shSource.ListObjects("Таблица1")
On Error GoTo 0
If Not tb Is Nothing Then
GetDataFromListObject tb
End If
End Sub
Private Sub GetDataFromListObject(tbSource As ListObject)
Dim aFields As Variant, vField As Variant
aFields = ARR_FIELDS
Dim obj As ListColumn, arr As Variant, ya As Long
ReDim arr(LBound(aFields) To UBound(aFields))
ya = LBound(arr) - 1
For Each vField In aFields
On Error Resume Next
Set obj = tbSource.ListColumns(vField)
On Error GoTo 0
If obj Is Nothing Then Exit Sub
ya = ya + 1
arr(ya) = GetArrayFromRange(obj.DataBodyRange)
Set obj = Nothing
Next
colTargetArrays.Add arr
End Sub
Private Function ShowFileDialog() As Variant
'ShowFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
Dim rInitialFileName As Range
On Error Resume Next
Set rInitialFileName = ThisWorkbook.Names("SourceFile").RefersToRange
On Error GoTo 0
Dim sInitialFileName As String
If Not rInitialFileName Is Nothing Then
sInitialFileName = rInitialFileName.Value
If Left(sInitialFileName, 2) = ".\" Then
sInitialFileName = Mid(sInitialFileName, 2)
sInitialFileName = ThisWorkbook.Path & sInitialFileName
End If
End If
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFD As FileDialog
Dim lf As Long
'назначаем переменной ссылку на экземпляр диалога
Set oFD = Application.FileDialog(msoFileDialogFilePicker)
With oFD 'используем короткое обращение к объекту
'так же можно без oFD
'With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Title = "Выбрать файлы" 'заголовок окна диалога
.Filters.Clear 'очищаем установленные ранее типы файлов
.Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
'.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
.FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
.InitialFileName = sInitialFileName
.InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
If .Show = 0 Then Exit Function 'показывает диалог
Dim arr As Variant, sName As String
'цикл по коллекции выбранных в диалоге файлов
For lf = 1 To .SelectedItems.Count
sName = fso.GetFileName(.SelectedItems(lf))
If Left(sName, 2) <> "~$" Then
If sName <> ThisWorkbook.Name Then
If IsEmpty(arr) Then
ReDim arr(1 To 1)
If Not rInitialFileName Is Nothing Then
sInitialFileName = .SelectedItems(lf)
sInitialFileName = Replace(sInitialFileName, ThisWorkbook.Path, ".")
rInitialFileName.Value = sInitialFileName
End If
Else
ReDim Preserve arr(1 To UBound(arr) + 1)
End If
arr(UBound(arr)) = .SelectedItems(lf) 'считываем полный путь к файлу
End If
End If
Next
ShowFileDialog = arr
End With
End Function
Private Function GetArrayFromRange(rr As Range) As Variant
Dim arr As Variant
If rr.Cells.CountLarge = 1 Then
ReDim arr(1 To 1, 1 To 1)
arr(1, 1) = rr.Value
Else
arr = rr.Value
End If
GetArrayFromRange = arr
End Function
Private Sub CloseEmptyWb()
Dim wb As Workbook
For Each wb In Application.Workbooks
If wb.Path = "" Then wb.Close False
Next
End Sub
|
