Question

我的桌面上的文件夹中有多个工作簿。我想从每个副本中复制Range(A14:L26)并将其粘贴到当前工作表的（主）表中（应放置在B：N列中）。同样，应将来自不同工作表的复制行放置在表中（我已经创建过）彼此之间。（为了能够在第二步中用数据透视图等可视化它们）

我当前的代码有两个问题。

会弹出FileDialogue，但告诉我在我要从中提取数据的工作表的文件夹中，没有文件可以满足我的要求。它们都是xlsm Excel工作簿，应从工作表Important Information中复制Range(A14:L26)。如何让它找到我要查找的文件？
范围中的某些单元格中有配方设计师。我只想复制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

从桌面上的文件夹中的所有关闭的工作簿中复制一定范围，并将其粘贴到当前（主）工作簿中

1 个答案: