将文件夹中所有工作簿中的数据复制到包含数据链接的摘要列表
Copy data from all workbooks in a folder to a summary list with links to the data
我正在尝试将大量工作簿复制到摘要工作簿中，到目前为止，我已经获得了以下代码来完成这项工作。
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
然而，是否可以将数据作为 link 而不是 "dead" 值来获取？因此，如果它在众多工作簿之一中发生更改，我只需要刷新摘要工作簿？
奖金问题：是否可以检查此位中的重复项：.Range("AK" & rowTarget).Value = sFile 并且仅在值不存在且新值应从第 5 行下方的最后一个空行添加时才添加？
您可以复制源区域，然后使用 特殊粘贴 › 在目标工作簿中粘贴 Link。它将公式 linking 粘贴到源工作簿复制的范围。
This short YouTube video 应该最能说明问题。
如有必要，您也可以使用 VBA 来做到这一点，例如：
wsSource.Range("C14").Copy
.Range("A" & rowTarget).Select
ActiveSheet.Paste Link:=True
似乎我们需要先 .Select 然后使用 ActiveSheet.Paste 否则 link 粘贴失败，即使这看起来是一个不好的做法，但下面直接引用了范围行不通！
wsSource.Range("C14").Copy
.Range("A" & rowTarget).Paste Link:=True 'fails with error 438
但是因为您现在使用公式 link 计算值，您可能只需要这样做一次，因此不再需要 VBA 解决方案，因为它更容易做到手工 一次。
注：
请注意，这些工作簿是 link 由公式编辑的。如果将源工作簿移动到另一个位置，link 将会中断（如果目标工作簿不在同一位置并且也被复制）。这伴随着 linked 工作簿的所有缺点。
//编辑
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
试试这个插件。它会完全按照你的要求去做。
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"
.Range("B" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$C"
.Range("C" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$C"
.Range("J" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$I"
.Range("K" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$I"
.Range("L" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$C"
.Range("M" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$E"
.Range("H" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$I"
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
我正在尝试将大量工作簿复制到摘要工作簿中，到目前为止，我已经获得了以下代码来完成这项工作。
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
然而，是否可以将数据作为 link 而不是 "dead" 值来获取？因此，如果它在众多工作簿之一中发生更改，我只需要刷新摘要工作簿？
奖金问题：是否可以检查此位中的重复项：.Range("AK" & rowTarget).Value = sFile 并且仅在值不存在且新值应从第 5 行下方的最后一个空行添加时才添加？
您可以复制源区域，然后使用 特殊粘贴 › 在目标工作簿中粘贴 Link。它将公式 linking 粘贴到源工作簿复制的范围。
This short YouTube video 应该最能说明问题。
如有必要，您也可以使用 VBA 来做到这一点，例如：
wsSource.Range("C14").Copy
.Range("A" & rowTarget).Select
ActiveSheet.Paste Link:=True
似乎我们需要先 .Select 然后使用 ActiveSheet.Paste 否则 link 粘贴失败，即使这看起来是一个不好的做法，但下面直接引用了范围行不通！
wsSource.Range("C14").Copy
.Range("A" & rowTarget).Paste Link:=True 'fails with error 438
但是因为您现在使用公式 link 计算值，您可能只需要这样做一次，因此不再需要 VBA 解决方案，因为它更容易做到手工 一次。
注：
请注意，这些工作簿是 link 由公式编辑的。如果将源工作簿移动到另一个位置，link 将会中断（如果目标工作簿不在同一位置并且也被复制）。这伴随着 linked 工作簿的所有缺点。
//编辑
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
试试这个插件。它会完全按照你的要求去做。
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"
.Range("B" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$C"
.Range("C" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$C"
.Range("J" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$I"
.Range("K" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$I"
.Range("L" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$C"
.Range("M" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$E"
.Range("H" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$I"
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