Скопируйте определенный диапазон из всех закрытых рабочих книг в папке на рабочем столе и вставьте его в текущую (основную) рабочую книгу.

Question

У меня есть несколько книг в папке на рабочем столе.Из каждого из них я хочу скопировать Range(A14:L26) и вставить его в (основную) таблицу на моем текущем рабочем листе (который должен быть помещен в столбец B: N).Также скопированные строки из разных листов должны быть помещены друг под другом в таблицу (которую я уже создал).(Чтобы иметь возможность визуализировать их с помощью сводной диаграммы и т. Д. На втором шаге)

У меня есть две проблемы с кодом, который у меня есть в настоящее время.

1. FileDialogue всплывает, но сообщает мне, что в папке, где находятся рабочие листы, из которых я хочу извлечь данные, не было файлов, удовлетворяющих моему требованию.Все они являются рабочими книгами xlsm Excel, и с листа Important Information Range(A14:L26) следует скопировать.Как я могу найти нужные мне файлы?

2. В некоторых ячейках диапазона есть формуляры.Я хочу скопировать только значение, отображаемое в Excel, а не в формуляр, поскольку соединение больше не работает после вставки ячеек в мою текущую книгу.(Примечание. Значения, отображаемые в Excel, представляют собой не только цифры, но и имена, поэтому использование функции VALUE() на рабочем листе не работает)

Кроме того, код не отображаетсялюбые ошибки.

Option Explicit

Sub PullDataRangeFromClosedFilesOnDesktop()
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName As String
    Dim xSheetName As String
    Dim xRgStr As String
    Dim xBook As Workbook
    Dim xWorkBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    xSheetName = "Important Information" 'CHANGE According to name of sheet 
                                         'that range is supposed to be  
                                         'copied from
    xRgStr = "A14:N26"
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
         If .Show = -1 Then
           xSelItem = .SelectedItems.Item(1)
           Set xWorkBook = ThisWorkbook
           Set xSheet = xWorkBook.Sheets("Tabelle1")
           If xSheet Is Nothing Then

   xWorkBook.Sheets.Add_
   (after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count))_
   .Name = "Daten zur Auswertung"
           Set xSheet = xWorkBook.Sheets("Daten zur Auswertung")
         End If

            xFileName = Dir(xSelItem & ".xlsm", vbNormal) 
         If xFileName = "" Then Exit Sub
            Do Until xFileName = ""
               Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
               Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
               xRg.Copy xSheet.Range("B").End(xlUp).Offset(1, 0)
               xFileName = Dir()
               xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Answer 1

Дорогая Анна, взгляни на этот код:

    Option Explicit

 Sub test()

    Dim strPath As String, strType As String, StrFile As String
    Dim wbLoop As Workbook, wbMaster As Workbook
    Dim Lastrow As Long

    Set wbMaster = Workbooks("Test Loop.xlsm")

    strPath = "C:\Users\XXXXX\Desktop\ALL Files\"
    strType = "*.xlsm"

    StrFile = Dir(strPath & strType, vbNormal)

    Do While Len(StrFile) > 0

        Workbooks.Open Filename:=strPath & StrFile

        Set wbLoop = Workbooks(StrFile)

        Lastrow = wbMaster.Worksheets("Sheet1").Cells(wbMaster.Worksheets("Sheet1").Rows.Count, "B").End(xlUp).Row

        wbLoop.Worksheets("Sheet1").Range("A14:L26").Copy wbMaster.Worksheets("Sheet1").Range("B" & Lastrow + 1)

        Workbooks(StrFile).Close SaveChanges:=False

        StrFile = Dir

    Loop

 End Sub