0

所以我有一个主工作簿（我们称之为 Workbook One），它需要从一系列其他工作簿中提取一个单元格的数据，通常以百分比形式，并在按钮按下时将其存放在一个列中点击。另一个工作簿的路径在工作簿一中列出。然而，路径是动态构建的。因此，工作簿名称是根据单元格 A1 中的输入构建的：=A1 和“.xlsx”，驱动器和文件夹路径如下所示：=N1 和 N2 和 N3 等，视文件夹和驱动器的数量而定姓名。这一切都出现在一个读取完整路径的单元中，但如果有必要，我可以（并且已经）单独提取零碎。

我的最终目标是通过一个按钮激活一个宏，该按钮贯穿工作簿列表，从每个工作簿中提取一个单元格中的数据，并将其存放在 Workbook One 的一系列单元格中。此外，该列表可能包含空白，因此如果可能，请跳过空白单元格。另外，我不喜欢这段代码，所以如果你有更好的方法，请告诉我。

目前我的代码如下所示：

Function dynamicPull()

Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim sourceRange As Integer, inputRow As Integer, fepTotal As Integer
fepTotal = Range("EventList!F2").Value 'total number of events to run through
sourceRange = 2
inputRow = 3

Dim sourceFile As String, inputRange As String, pullRange As String, pullData As String
sourceFile = Range("Settings!Q" & sourceRange).Value 'currently unused
pullRange = Range("Settings!$N$23").Value 'cell to pull from in series of workbooks

Dim wbSource As Workbook, wbMain As Workbook
Set wbMain = ThisWorkbook

Dim sourceFile1 As String, sourceFile2 As String, sourceFile3 As String
sourceFile1 = Range("Settings!$N$26").Value 'pathing to workbook, ie C:\Folder1\Folder2\
sourceFile2 = Range("Settings!R" & sourceRange).Value 'workbook name
sourceFile3 = "Cover Sheet" 'sheet name

If fepTotal >= 1 Then
 checkedEvents = 0 'checkedEvents is dimmed in declarations
 error = 0
 For pullLoop = 1 To fepTotal
  sourceRange = 2
  inputRow = 3
  inputRange = "D" & inputRow 'where i want the pulled data to go
  sourceFile2 = Range("Settings!R" & sourceRange).Value 'workbook name
  pullData = GetValue(sourceFile1, sourceFile2, sourceFile3, pullRange)
  If pullData = "FnF" Then
   'wbMain.Sheets("EventList").Range(inputRange).Value = "FnF"
   GoTo FnF
  Else
   wbMain.Sheets("EventList").Range(inputRange).Value = pullData
   checkedEvents = checkedEvents + 1
  End If
FnF:
  inputRow = inputRow + 1 'shifts to next input cell (D4, D5, etc)
  sourceRange = sourceRange + 1 'shifts to next cell containing next document pathing
 Next pullLoop
Else
 error = MsgBox("No event inputs to derive from.", vbCritical, "ERROR")
 error = 1
End If

sourceRange = 2 'resets sourceRange to first pull cell
inputRow = 3
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

End Function

'Function GetValue(path, file, sheet, ref)
'   Retrieves a value from a closed workbook
'    Dim arg As String
'   Make sure the file exists
'    If Right(path, 1) <> "\" Then path = path & "\"
'    If Dir(path & file) = "" Then
'     GetValue = "FnF"
'     Exit Function
'    End If
'   Create the argument
'    arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
'     Range(ref).Range("A1").Address(, , xlR1C1)
'   Execute an XLM macro
'    GetValue = ExecuteExcel4Macro(arg)
'End Function

Function GetValue(ByVal sPath As String, sFile As String, _
              sSht As String, sRng As String) As Variant
' Retrieves a value from a closed workbook
' VBA only
Dim sArg As String

If Right(sPath, 1) <> "\" Then sPath = sPath & "\"

If Len(Dir(sPath & sFile)) Then 'Runtime error 52: Bad file name or number
    sArg = "'" & sPath & _
           "[" & sFile & "]" & _
           sSht & "'!" & _
           Application.ConvertFormula(sRng, xlA1, xlR1C1, True)
    GetValue = ExecuteExcel4Macro(sArg)
Else
    GetValue = "File not found"
End If
End Function

我发现了其他几篇可能有用的帖子：

从关闭的工作簿中提取 - 堆栈溢出

GetValue 函数 - 电子表格页面

我已经为此苦苦挣扎了一段时间，非常感谢任何和所有帮助。我会尽快回答任何问题，提供任何反馈等。再次感谢。

4

1 回答 1

0

工作代码如下：

Function dynamicPull()

Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim sourceRange As Integer, inputRow As Integer, fepTotal As Integer
fepTotal = Range("EventList!F2").Value

Dim inputRange As String, pullRange As String, pullData As String
pullRange = Range("Settings!$N$23").Value

Dim wbSource As Workbook, wbMain As Workbook
Set wbMain = ThisWorkbook

Dim sourceFile1 As String, sourceFile2 As String, sourceFile3 As String
sourceFile1 = Range("Settings!$N$26").Value 'pathing to workbook, ie C:\Folder1\Folder2\
sourceFile3 = "Cover Sheet" 'sheet name

If fepTotal >= 1 Then
 checkedEvents = 0
 error = 0
 For pullLoop = 1 To fepTotal
 If pullLoop = 1 Then
  sourceRange = 2
  inputRow = 3
 End If
 inputRange = "D" & inputRow
 sourceFile2 = Range("Settings!R" & sourceRange).Value 'workbook name
 pullData = GetValue(sourceFile1, sourceFile2, sourceFile3, pullRange)
 If pullData = "FnF" Then
  GoTo FnF
 Else
 wbMain.Sheets("EventList").Range(inputRange).Value = pullData
 checkedEvents = checkedEvents + 1
End If
FnF:
 inputRow = inputRow + 1
 sourceRange = sourceRange + 1
Next pullLoop
Else
 error = MsgBox("No event inputs to derive from.", vbCritical, "ERROR")
 error = 1
End If

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

End Function

Function GetValue(ByVal sPath As String, sFile As String, _
              sSht As String, sRng As String) As Variant
' Retrieves a value from a closed workbook
' VBA only
Dim sArg As String

If Right(sPath, 1) <> "\" Then sPath = sPath & "\"

If Len(Dir(sPath & sFile)) Then
    sArg = "'" & sPath & _
           "[" & sFile & "]" & _
           sSht & "'!" & _
           Application.ConvertFormula(sRng, xlA1, xlR1C1, True)
    GetValue = ExecuteExcel4Macro(sArg)
Else
    GetValue = "NO DATA"
End If
End Function

如果您有任何问题，请告诉我。我对整个代码进行了评论，以解释一些变量等。再次感谢所有帮助。

于 2017-06-20T17:15:26.337 回答