Блог

У меня следующая ситуация: есть основная папка с большим количеством вложенных папок. В каждой из этих вложенных папок есть 3-4 PDF-файла и, как правило, один файл Excel. Теперь я создал макрос, который после нажатия кнопки и выбора основной папки скопировал определенные столбцы файлов Excel из всех вложенных папок и объединил их на листе. Основной процесс копирования работает, но возникли следующие проблемы:

1. Я хочу, чтобы копировались только значения ячеек, а не функции. К сожалению, я не смог найти рабочего решения этой проблемы.
2. Редко случается, что во вложенной папке находится более одного файла Excel. В этом случае содержимое обоих файлов также должно быть скопировано. На данный момент копируется только содержимое одного файла. К сожалению, я тоже не смог найти решение здесь.

Я был бы очень признателен, если бы кто-нибудь мог мне здесь помочь.

 Sub FolderNames()
'Update 20141027
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim xPath As String
Dim xWs As Worksheet
Dim fso As Object, j As Long, folder1 As Object
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Choose the folder"
    .Show
End With
On Error Resume Next
xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) amp; ""
'Application.Workbooks.Add
Set xWs = ThisWorkbook.Sheets("FolderList")
xWs.Cells.Clear
xWs.Cells(1, 1).Value = xPath
xWs.Cells(2, 1).Value = "Path"
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder1 = fso.GetFolder(xPath)
getSubFolder folder1

xWs.Range("1:2").Delete xlUp
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub getSubFolder(ByRef prntfld As Object)
Dim SubFolder As Object
Dim subfld As Object
Dim xRow As Long
For Each SubFolder In prntfld.SubFolders
    xRow = ThisWorkbook.Sheets("FolderList").Range("A1").End(xlDown).Row   1
    ThisWorkbook.Sheets("FolderList").Cells(xRow, 1) = SubFolder.Path
Next SubFolder
For Each subfld In prntfld.SubFolders
    getSubFolder subfld
Next subfld
End Sub



Sub getfiles()
Application.DisplayAlerts = False
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
Dim lrow As Long
Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim FileFound As Boolean
Dim targetfile As Workbook
Dim firstfile As Boolean
firstfile = True
lrow = ThisWorkbook.Sheets("FolderList").Cells(Rows.Count, 1).End(xlUp).Row
Dim filecount As Long
filecount = 0
ThisWorkbook.Worksheets("Konsolidierung").Cells.Clear

For j = 1 To lrow
Set oFolder = oFSO.GetFolder(ThisWorkbook.Sheets("FolderList").Cells(j, 1).Text)

    filecount = filecount   1

For Each oFile In oFolder.Files

    If Right(oFile.Name, 4) = "xlsx" Then
    FileFound = True
    Set targetfile = Workbooks.Open(ThisWorkbook.Sheets("FolderList").Cells(j, 1).Text amp; "" amp; oFile.Name)
    
    If firstfile Then
    targetfile.Sheets(1).Range("A:F").Copy ThisWorkbook.Worksheets("Konsolidierung").Cells(1, 1)
    firstfile = False
    Else
    
    targetfile.Sheets(1).Range("F:F").Copy ThisWorkbook.Worksheets("Konsolidierung").Cells(1, filecount   5)
    End If
    
    targetfile.Close False
    
        
    End If
    
    
    

Next oFile

If FileFound = False Then
ThisWorkbook.Worksheets("Konsolidierung").Cells(1, filecount   5) = "Keine Datei gefunden"
Else
FileFound = False
End If

Next j


Application.DisplayAlerts = True
End Sub