Question

所以我有一个主要工作簿（我们称之为Workbook One），需要从一系列其他工作簿中提取一个单元格的数据，通常是百分比形式，并将其存入单击按钮时的列。另一个工作簿的路径列在Workbook One中。然而，路径是动态构建的。因此，工作簿名称是从单元格A1中的输入构建的，如下所示：= A1＆amp; ＆＃34; .xlsx＆＃34;，将驱动器和文件夹路径拉得如此：= N1＆amp; N2＆amp;根据文件夹和驱动器名称的数量，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

我发现了其他一些可能有用的帖子：

Pulling from closed workbook - Stack overflow

GetValue function - The Spreadsheet Page

我已经在这方面挣扎了很长一段时间，所有的帮助都非常感激。我会尽快回答任何问题，提供任何反馈等。再次感谢。

Answer 1

工作代码如下：

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

如果您有任何疑问，请与我们联系。我在整个代码中评论了解释一些变量等等。再次感谢所有的帮助。

从一系列已关闭的Excel工作簿中提取数据并更改名称

1 个答案: