将数据从文件夹中的所有工作簿复制到摘要列表，其中包含指向数据

时间：2018-02-28 06:42:34

标签： excel-vba hyperlink summarization vba excel

我试图将大量工作簿复制到摘要工作簿中，到目前为止，我已经获得了以下代码来完成这项工作。 

Option Explicit


Const FOLDER_PATH = "Folderpath\"  'REMEMBER END BACKSLASH

Sub ImportWorksheets()
   '=============================================
   'Process all Excel files in specified folder
   '=============================================
   Dim sFile As String           'file to process
   Dim wsTarget As Worksheet
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim rowTarget As Long         'output row

   rowTarget = Sheets("Status").Cells(Rows.Count, "AK").End(xlUp).Row + 1

   'check the folder exists
   If Not FileFolderExists(FOLDER_PATH) Then
      MsgBox "Specified folder does not exist, exiting!"
      Exit Sub
   End If

   'reset application settings in event of error
   'On Error GoTo errHandler
   'Application.ScreenUpdating = False

   'set up the target worksheet
   Set wsTarget = Sheets("Status")

   'loop through the Excel files in the folder
   sFile = Dir(FOLDER_PATH & "*.xls*")
   Do Until sFile = ""

      'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
      Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
      Set wsSource = wbSource.Worksheets("Side 1-Forside") 'EDIT IF NECESSARY

      'import the data
      With wsTarget
         .Activate
         wsSource.Range("C14").Copy
         .Range("A" & rowTarget).Select
         ActiveSheet.Paste Link:=True
         wsSource.Range("C15").Copy
         .Range("B" & rowTarget).Select
         ActiveSheet.Paste Link:=True
         wsSource.Range("C13").Copy
         .Range("C" & rowTarget).Select
         ActiveSheet.Paste Link:=True
         wsSource.Range("I11").Copy
         .Range("J" & rowTarget).Select
         ActiveSheet.Paste Link:=True
         wsSource.Range("I10").Copy
         .Range("K" & rowTarget).Select
         ActiveSheet.Paste Link:=True
         wsSource.Range("C40").Copy
         .Range("L" & rowTarget).Select
         ActiveSheet.Paste Link:=True
         wsSource.Range("E40").Copy
         .Range("M" & rowTarget).Select
         ActiveSheet.Paste Link:=True
         wsSource.Range("I9").Copy
         .Range("H" & rowTarget).Select
         ActiveSheet.Paste Link:=True
         'optional source filename in the last column

            .Range("AK" & rowTarget).Value = sFile
      End With

      'close the source workbook, increment the output row and get the next file
      wbSource.Close SaveChanges:=False
      rowTarget = rowTarget + 1
      sFile = Dir()
   Loop

'errHandler:
   'On Error Resume Next
   'Application.ScreenUpdating = True

   'tidy up
   Set wsSource = Nothing
   Set wbSource = Nothing
   Set wsTarget = Nothing
End Sub


Private Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function

然而，可以将数据作为链接而不是“死亡”＃34;值？因此，如果它在许多工作簿中的一个中被更改，我只需要刷新摘要工作簿？

Bonusquestion：是否可以检查此位中的重复项：.Range("AK" & rowTarget).Value = sFile并且只有在值已经存在并且新值应该从第5行下方的最后一个空行添加时才添加？ / p>

3 个答案:

答案 0 :(得分：1)

您可以复制源范围，然后在目标工作簿中使用特殊粘贴>粘贴链接。它粘贴一个链接到源工作簿复制范围的公式 This short YouTube video应该最好地说明这一点。

如果需要，您也可以使用VBA执行此操作，例如：

wsSource.Range("C14").Copy
.Range("A" & rowTarget).Select
ActiveSheet.Paste Link:=True

似乎我们首先需要.Select并使用ActiveSheet.Paste否则链接粘贴失败，即使这看起来像是一种不好的做法，但以下直接参考范围不会起作用！

wsSource.Range("C14").Copy
.Range("A" & rowTarget).Paste Link:=True 'fails with error 438

但是因为您现在使用公式将值链接起来，您可能只需要执行一次，因此不再需要VBA解决方案，因为它更容易执行一次用手。

注意：
请注意，这些工作簿是通过公式链接的。如果将源工作簿移动到另一个位置，链接将中断（如果目标工作簿不在同一位置并复制）。这带来了链接工作簿的所有缺点。

//修改

With wsTarget
    .Activate
    .Range("A" & rowTarget).Select
    wsSource.Range("C14").Copy 
    .Paste Link:=True
    .Activate
    .Range("B" & rowTarget).Select
    wsSource.Range("C15").Copy        
    .Paste Link:=True

答案 1 :(得分：0)

Peh建议的替代解决方案，两者都有效，但下面的方法并不灵活，而是硬编码。以为我会分享。 

Option Explicit


Const FOLDER_PATH = "Folderpath\"  'REMEMBER END BACKSLASH

Sub ImportWorksheets()
   '=============================================
   'Process all Excel files in specified folder
   '=============================================
   Dim sFile As String           'file to process
   Dim wsTarget As Worksheet
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim rowTarget As Long         'output row

   rowTarget = Sheets("Status").Cells(Rows.Count, "AK").End(xlUp).Row + 1

   'check the folder exists
   If Not FileFolderExists(FOLDER_PATH) Then
      MsgBox "Specified folder does not exist, exiting!"
      Exit Sub
   End If

   'reset application settings in event of error
   'On Error GoTo errHandler
   'Application.ScreenUpdating = False

   'set up the target worksheet
   Set wsTarget = Sheets("Status")

   'loop through the Excel files in the folder
   sFile = Dir(FOLDER_PATH & "*.xls*")
   Do Until sFile = ""

      'import the data
      With wsTarget

         'optional source filename in the last column
         .Range("AK" & rowTarget).Value = sFile
         .Range("A" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$C$14"
         .Range("B" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$C$15"
         .Range("C" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$C$13"
         .Range("J" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$I$11"
         .Range("K" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$I$10"
         .Range("L" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$C$40"
         .Range("M" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$E$40"
         .Range("H" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$I$9"

      End With

      'close the source workbook, increment the output row and get the next file
      rowTarget = rowTarget + 1
      sFile = Dir()
   Loop

'errHandler:
   'On Error Resume Next
   'Application.ScreenUpdating = True

   'tidy up
   Set wsSource = Nothing
   Set wbSource = Nothing
   Set wsTarget = Nothing
End Sub


Private Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function

答案 2 :(得分：-1)

试试这个AddIn。它会完全符合您的要求。

enter image description here

https://www.rondebruin.nl/win/addins/rdbmerge.htm

相关问题
最新问题