Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос_Вставка данных в файли из сводного файла
 
#1
01.11.2024 08:36:39
Уважаемы форумчане, помогите пожалуйста с написанием макроса.
Есть Сводный файл с данными. Эти данные нужно вставить в файлы отчетов, котороые лежать в отдельной папке.
Каждый отчет имеет своё имя , но внутренняя структура у этих отчётов одинаковая.
В сводном файле есть столбец с именами отчетов и данные , который нужно вставить как значение в соответствующий отчет, в определенную ячейку отчета (адресно).
Отчетных файлов может быть большое количество.
Буду очень признателен если поможите.
Изменено: cityfox - 01.11.2024 09:02:47
 
 
 
#2
01.11.2024 09:51:47
Цитата
cityfox написал:
Отчетных файлов может быть большое количество.
Вот это для чего? Зачем их большое количество?
Может это подойдет
Заполнение бланков данными из таблицы
Согласие есть продукт при полном непротивлении сторон
 
 
 
#3
01.11.2024 10:32:06
Цитата
написал:
Вот это для чего? Зачем их большое количество?
это отчеты, которые присылают менеджеры их в месяц может быть 5 , а может 100! Когда их мало, можно и руками вставить, но в последнее время 70-100 приходит и руками вставлять данные занимает много времени. в каждый отчет вставляем 5-15 параметров.
 
 
 
#4
01.11.2024 11:54:15
Код
Option Explicit
Public fso As Object

Sub Вставить_данные()
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim shTarget As Worksheet
    Set shTarget = ActiveSheet

    Dim aFiles As Variant
    aFiles = ShowFileDialog(shTarget.Cells(1, 20))
    If IsEmpty(aFiles) Then Exit Sub
    
    Dim Application_Calculation As XlCalculation
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim wb As Workbook
    Dim vFile As Variant
    For Each vFile In aFiles
        Application.StatusBar = fso.GetBaseName(vFile)
        DoEvents
        Application.ScreenUpdating = False
        Set wb = GetWb(vFile)
        If Not wb Is Nothing Then
            
            CollectFromSheet wb.Sheets(1), shTarget.Range("A2:A4"), shTarget.Range("B1:D1")
            
            wb.Close False
            Set wb = Nothing
        End If
        Application.ScreenUpdating = True
        Application.StatusBar = False
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Sub CollectFromSheet(shSource As Worksheet, targetReports As Range, targetParams As Range)
    Dim yt As Long
    On Error Resume Next
    yt = WorksheetFunction.Match(fso.GetBaseName(shSource.Parent.Name), targetReports, 0)
    On Error GoTo 0
    If yt = 0 Then
    Else
        Dim sourceParam As Range
        Dim targetParam As Range
        Dim targetCell As Range
        For Each targetParam In targetParams.Cells
            Set targetCell = Intersect(targetReports.Rows(yt).EntireRow, targetParam.EntireColumn)
                
            On Error Resume Next
            Set sourceParam = shSource.Cells.Find(what:=targetParam.Value)
            On Error GoTo 0
            If Not sourceParam Is Nothing Then
                targetCell.Value = sourceParam.Cells(1, 2).Value
                Set sourceParam = Nothing
            Else
                targetCell.ClearContents
            End If
        Next
    End If
End Sub

Private Function ShowFileDialog(rInitialFileName As Range) As Variant
    'ShowFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    Dim oFD As FileDialog
    Dim x, 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 = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Private Function GetWb(ByVal sFull As String) As Workbook
    If Not fso.FileExists(sFull) Then Exit Function
    Dim sName As String
    sName = fso.GetFileName(sFull)
    
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If LCase(wb.FullName) <> LCase(sFull) Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, True)
    End If
    
    Set GetWb = wb
End Function
 
 
 
#5
01.11.2024 14:49:48
МатросНаЗебре,

этот макрос собирает данные из отчетов. Я немного про другое писал. Чтобы из сводного файла данные переносились в отчеты.  
 
 
 
#6
01.11.2024 15:00:25
Упс, не туда вставил  :D
Код
Option Explicit
Public fso As Object

Sub Распылить_данные()
    BothDirectionDataCopy False
End Sub

Sub Собрать_данные()
    BothDirectionDataCopy True
End Sub

Private Sub BothDirectionDataCopy(fromManyToOne As Boolean)
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim shTarget As Worksheet
    Set shTarget = ActiveSheet

    Dim aFiles As Variant
    aFiles = ShowFileDialog(shTarget.Cells(1, 20))
    If IsEmpty(aFiles) Then Exit Sub
    
    Dim Application_Calculation As XlCalculation
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim wb As Workbook
    Dim vFile As Variant
    For Each vFile In aFiles
        Application.StatusBar = fso.GetBaseName(vFile)
        DoEvents
        Application.ScreenUpdating = False
        Set wb = GetWb(vFile)
        If Not wb Is Nothing Then
            
            CollectFromSheet wb.Sheets(1), shTarget.Range("A2:A4"), shTarget.Range("B1:D1"), fromManyToOne
            
            wb.Close True
            Set wb = Nothing
        End If
        Application.ScreenUpdating = True
        Application.StatusBar = False
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Sub CollectFromSheet(shSource As Worksheet, targetReports As Range, targetParams As Range, fromManyToOne As Boolean)
    Dim yt As Long
    On Error Resume Next
    yt = WorksheetFunction.Match(fso.GetBaseName(shSource.Parent.Name), targetReports, 0)
    On Error GoTo 0
    If yt = 0 Then
    Else
        Dim sourceParam As Range
        Dim targetParam As Range
        Dim targetCell As Range
        For Each targetParam In targetParams.Cells
            Set targetCell = Intersect(targetReports.Rows(yt).EntireRow, targetParam.EntireColumn)
                
            On Error Resume Next
            Set sourceParam = shSource.Cells.Find(what:=targetParam.Value)
            On Error GoTo 0
            If Not sourceParam Is Nothing Then
                If fromManyToOne Then
                    targetCell.Value = sourceParam.Cells(1, 2).Value
                Else
                    sourceParam.Cells(1, 2).Value = targetCell.Value
                End If
                Set sourceParam = Nothing
            Else
                If fromManyToOne Then targetCell.ClearContents
            End If
        Next
    End If
End Sub

Private Function ShowFileDialog(rInitialFileName As Range) As Variant
    'ShowFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    Dim oFD As FileDialog
    Dim x, 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 = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Private Function GetWb(ByVal sFull As String) As Workbook
    If Not fso.FileExists(sFull) Then Exit Function
    Dim sName As String
    sName = fso.GetFileName(sFull)
    
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If LCase(wb.FullName) <> LCase(sFull) Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
    
    Set GetWb = wb
End Function
 
 
 
#7
01.11.2024 15:56:16
МатросНаЗебре,  8-0  Спасибо большое.
а как сделать адресную вставку. ну например. из сводной , Параметр1 отчета 1 вставляем в ячейку F10 отчета1 , параметр 2 в ячейку с4.? параметр 3 в ячейку F18 !
и ещё , название листа (в файле Отчет1,2,3) в который вносим данные нужно в макросе прописывать ? В файле отчета много листов, но вставляем данные в основной лист "Total"
 
 
 
#8
01.11.2024 16:08:30
Цитата
написал:
название листа (в файле Отчет1,2,3) в который вносим данные нужно в макросе прописывать ? В файле отчета много листов, но вставляем данные в основной лист "Total"
Код
Option Explicit
Public fso As Object

Private Const TARGET_SHEET_NAME = "Total"

Sub Распылить_данные()
    BothDirectionDataCopy False
End Sub

Sub Собрать_данные()
    BothDirectionDataCopy True
End Sub

Private Sub BothDirectionDataCopy(fromManyToOne As Boolean)
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim shTarget As Worksheet
    Set shTarget = ActiveSheet

    Dim aFiles As Variant
    aFiles = ShowFileDialog(shTarget.Cells(1, 20))
    If IsEmpty(aFiles) Then Exit Sub
    
    Dim Application_Calculation As XlCalculation
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim wb As Workbook
    Dim sourceSheet As Worksheet
    Dim vFile As Variant
    For Each vFile In aFiles
        Application.StatusBar = fso.GetBaseName(vFile)
        DoEvents
        Application.ScreenUpdating = False
        Set wb = GetWb(vFile)
        If Not wb Is Nothing Then
            On Error Resume Next
            Set sourceSheet = wb.Sheets(TARGET_SHEET_NAME)
            On Error GoTo 0
            If Not sourceSheet Is Nothing Then
                CollectFromSheet sourceSheet, shTarget.Range("A2:A4"), shTarget.Range("B1:D1"), fromManyToOne
                wb.Close True
            Else
                wb.Close False
            End If
            
            Set wb = Nothing
        End If
        Application.ScreenUpdating = True
        Application.StatusBar = False
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Sub CollectFromSheet(shSource As Worksheet, targetReports As Range, targetParams As Range, fromManyToOne As Boolean)
    Dim yt As Long
    On Error Resume Next
    yt = WorksheetFunction.Match(fso.GetBaseName(shSource.Parent.Name), targetReports, 0)
    On Error GoTo 0
    If yt = 0 Then
    Else
        Dim sourceParam As Range
        Dim targetParam As Range
        Dim targetCell As Range
        For Each targetParam In targetParams.Cells
            Set targetCell = Intersect(targetReports.Rows(yt).EntireRow, targetParam.EntireColumn)
                
            On Error Resume Next
            Set sourceParam = shSource.Cells.Find(what:=targetParam.Value)
            On Error GoTo 0
            If Not sourceParam Is Nothing Then
                If fromManyToOne Then
                    targetCell.Value = sourceParam.Cells(1, 2).Value
                Else
                    sourceParam.Cells(1, 2).Value = targetCell.Value
                End If
                Set sourceParam = Nothing
            Else
                If fromManyToOne Then targetCell.ClearContents
            End If
        Next
    End If
End Sub

Private Function ShowFileDialog(rInitialFileName As Range) As Variant
    'ShowFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    Dim oFD As FileDialog
    Dim x, 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 = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Private Function GetWb(ByVal sFull As String) As Workbook
    If Not fso.FileExists(sFull) Then Exit Function
    Dim sName As String
    sName = fso.GetFileName(sFull)
    
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If LCase(wb.FullName) <> LCase(sFull) Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
    
    Set GetWb = wb
End Function
 
 
 
#9
01.11.2024 16:22:29
Цитата
написал:
а как сделать адресную вставку.
Код
Option Explicit
Public fso As Object

Private Const TARGET_SHEET_NAME = "Total"
Private Const COMMAND_STRING = "Параметр 1:F10, Параметр 2:F11, Параметр 3:F12"

Sub Распылить_данные()
    BothDirectionDataCopy False
End Sub

Sub Собрать_данные()
    BothDirectionDataCopy True
End Sub

Private Sub BothDirectionDataCopy(fromManyToOne As Boolean)
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim shTarget As Worksheet
    Set shTarget = ActiveSheet

    Dim aFiles As Variant
    aFiles = ShowFileDialog(shTarget.Cells(1, 20))
    If IsEmpty(aFiles) Then Exit Sub
    
    Dim Application_Calculation As XlCalculation
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim dic As Object
    Set dic = GetDic()
    
    Dim wb As Workbook
    Dim sourceSheet As Worksheet
    Dim vFile As Variant
    For Each vFile In aFiles
        Application.StatusBar = fso.GetBaseName(vFile)
        DoEvents
        Application.ScreenUpdating = False
        Set wb = GetWb(vFile)
        If Not wb Is Nothing Then
            On Error Resume Next
            Set sourceSheet = wb.Sheets(TARGET_SHEET_NAME)
            On Error GoTo 0
            If Not sourceSheet Is Nothing Then
                CollectFromSheet sourceSheet, shTarget.Range("A2:A4"), shTarget.Range("B1:D1"), fromManyToOne, dic
                wb.Close True
            Else
                wb.Close False
            End If
            
            Set wb = Nothing
        End If
        Application.ScreenUpdating = True
        Application.StatusBar = False
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Function GetDic() As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    
    Dim aa As Variant
    Dim arr As Variant
    Dim brr As Variant
    arr = Split(COMMAND_STRING, ",")
    For Each aa In arr
        brr = Split(Trim(aa), ":")
        dic(brr(0)) = brr(1)
    Next
    
    Set GetDic = dic
End Function

Private Sub CollectFromSheet(shSource As Worksheet, targetReports As Range, targetParams As Range, fromManyToOne As Boolean, dic As Object)
    Dim yt As Long
    On Error Resume Next
    yt = WorksheetFunction.Match(fso.GetBaseName(shSource.Parent.Name), targetReports, 0)
    On Error GoTo 0
    If yt = 0 Then
    Else
        Dim sourceParam As Range
        Dim targetParam As Range
        Dim targetCell As Range
        For Each targetParam In targetParams.Cells
            Set targetCell = Intersect(targetReports.Rows(yt).EntireRow, targetParam.EntireColumn)
                
            If dic.Exists(targetParam.Value) Then
                On Error Resume Next
                Set sourceParam = shSource.Range(dic(targetParam.Value))
                On Error GoTo 0
            End If
            If sourceParam Is Nothing Then
                On Error Resume Next
                Set sourceParam = shSource.Cells.Find(what:=targetParam.Value).Cells(1, 2)
                On Error GoTo 0
            End If
            
            If Not sourceParam Is Nothing Then
                If fromManyToOne Then
                    targetCell.Value = sourceParam.Value
                Else
                    sourceParam.Value = targetCell.Value
                End If
                Set sourceParam = Nothing
            Else
                If fromManyToOne Then targetCell.ClearContents
            End If
        Next
    End If
End Sub

Private Function ShowFileDialog(rInitialFileName As Range) As Variant
    'ShowFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    Dim oFD As FileDialog
    Dim x, 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 = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Private Function GetWb(ByVal sFull As String) As Workbook
    If Not fso.FileExists(sFull) Then Exit Function
    Dim sName As String
    sName = fso.GetFileName(sFull)
    
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If LCase(wb.FullName) <> LCase(sFull) Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
    
    Set GetWb = wb
End Function

Настроить можно с помощью строки
Private Const COMMAND_STRING = "Параметр 1:F10, Параметр 2:F11, Параметр 3:F12"
 
 
 
#10
01.11.2024 18:08:23
МатросНаЗебре,  спасибо Вам большое! то, что нужно!
 
 
 
#11
19.11.2024 11:28:13
МатросНаЗебре,

а ещё не подскажите, как в макрос прописать вставку в другой лист файла.
сейчас вставка данных ("Параметр 1:F10, Параметр 2:F11, Параметр 3:F12")  идет в лист "Total" , а как прописать , чтобы часть данных вставлялась в лист "total' допустим  ("Параметр 1:F10, Параметр 2:F11) ,а параметр (Параметр 3:F12)  в лист , например "final" . Все эти листы в одной книге.
Изменено: cityfox - 19.11.2024 11:55:17
 
 
 
#12
19.11.2024 15:58:06
Код
Option Explicit
Public fso As Object

Private Const TARGET_SHEET_NAME = "Total"
Private Const COMMAND_STRING = "Параметр 1:total!F10, Параметр 2:total!F11, Параметр 3:final!F12"

Sub Распылить_данные()
    BothDirectionDataCopy False
End Sub

Sub Собрать_данные()
    BothDirectionDataCopy True
End Sub

Private Sub BothDirectionDataCopy(fromManyToOne As Boolean)
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim shTarget As Worksheet
    Set shTarget = ActiveSheet

    Dim aFiles As Variant
    aFiles = ShowFileDialog(shTarget.Cells(1, 20))
    If IsEmpty(aFiles) Then Exit Sub
    
    Dim Application_Calculation As XlCalculation
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim dic As Object
    Set dic = GetDic()
    
    Dim wb As Workbook
    Dim sourceSheet As Worksheet
    Dim vFile As Variant
    For Each vFile In aFiles
        Application.StatusBar = fso.GetBaseName(vFile)
        DoEvents
        Application.ScreenUpdating = False
        Set wb = GetWb(vFile)
        If Not wb Is Nothing Then
            On Error Resume Next
            Set sourceSheet = wb.Sheets(TARGET_SHEET_NAME)
            On Error GoTo 0
            If Not sourceSheet Is Nothing Then
                CollectFromSheet sourceSheet, shTarget.Range("A2:A4"), shTarget.Range("B1:D1"), fromManyToOne, dic
                wb.Close True
            Else
                wb.Close False
            End If
            
            Set wb = Nothing
        End If
        Application.ScreenUpdating = True
        Application.StatusBar = False
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Function GetDic() As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    
    Dim aa As Variant
    Dim arr As Variant
    Dim brr As Variant
    arr = Split(COMMAND_STRING, ",")
    For Each aa In arr
        brr = Split(Trim(aa), ":")
        dic(brr(0)) = Split(Trim(brr(1)), "!")
    Next
    
    Set GetDic = dic
End Function

Private Sub CollectFromSheet(shSource As Worksheet, targetReports As Range, targetParams As Range, fromManyToOne As Boolean, dic As Object)
    Dim yt As Long
    On Error Resume Next
    yt = WorksheetFunction.Match(fso.GetBaseName(shSource.Parent.Name), targetReports, 0)
    On Error GoTo 0
    If yt = 0 Then
    Else
        Dim aItem As Variant
        Dim sourceParam As Range
        Dim targetParam As Range
        Dim targetCell As Range
        For Each targetParam In targetParams.Cells
            Set targetCell = Intersect(targetReports.Rows(yt).EntireRow, targetParam.EntireColumn)
                
            If dic.Exists(targetParam.Value) Then
                aItem = dic(targetParam.Value)
                On Error Resume Next
                Set sourceParam = shSource.Parent.Sheets(aItem(0)).Range(aItem(1))
                On Error GoTo 0
            End If
            If sourceParam Is Nothing Then
                On Error Resume Next
                Set sourceParam = shSource.Cells.Find(what:=targetParam.Value).Cells(1, 2)
                On Error GoTo 0
            End If
            
            If Not sourceParam Is Nothing Then
                If fromManyToOne Then
                    targetCell.Value = sourceParam.Value
                Else
                    sourceParam.Value = targetCell.Value
                End If
                Set sourceParam = Nothing
            Else
                If fromManyToOne Then targetCell.ClearContents
            End If
        Next
    End If
End Sub

Private Function ShowFileDialog(rInitialFileName As Range) As Variant
    'ShowFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    Dim oFD As FileDialog
    Dim x, 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 = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Private Function GetWb(ByVal sFull As String) As Workbook
    If Not fso.FileExists(sFull) Then Exit Function
    Dim sName As String
    sName = fso.GetFileName(sFull)
    
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If LCase(wb.FullName) <> LCase(sFull) Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
    
    Set GetWb = wb
End Function
С учётом длины кода, такие вопросы лучше сразу задавать, шанс получить ответ несколько выше.
 
 
 
#13
19.11.2024 17:34:32
Цитата
Цитата
написал:
С учётом длины кода, такие вопросы лучше сразу задавать, шанс получить ответ несколько выше.
только сейчас возникла потребность в таком вопросе.
Протестировал код. В лист Total данные вставляются., а в лист final - нет.
в коде прописан только лист Total. а лист Final не нужно в коде прописывать ?
 
 
 
Страницы: 1
Наверх