Question

我正在创建一个宏，它将打开目录中的每个工作簿，并根据文件类型和工作表名称等几个因素将数据提取到我的新工作簿中。我可以根据它在工作表上的位置拉出大部分所有这些数据，但是我有一个需要将值直接拉到一个在版本之间多次改变位置的标题之下的数据。目前，它将成功找到正确的值并将其放在我原来的工作簿中。但是，当工作簿中存在符合我的条件的多个工作表时，它将只重复第一个工作表上找到的第一个值，而不是执行搜索并从每个工作表中获取值。下面的代码标有相关部分。任何想法如何解决这个问题将不胜感激！

Option Explicit
Dim strMasterWorkbook As String
Dim strLinkWbk As String
Dim strImportSheet As String
Dim strQueryPath As String
Dim strCurrentFilePath As String
Dim strFileName As String
Dim strCurrentFile As String
Dim intLine As Integer
Dim intExtLine As Integer
Dim intFound As Integer
Dim intSheets As Integer
Dim intLastLine As Integer
Dim dtCurrentFileModified As Date
Dim intLastLine2 As Integer
Dim intLine2 As Integer
Dim intImport As Integer
Dim intLoc As Integer
Dim strCurrentLocation As String
Dim countentry, countfound, n As Integer
Dim count_intLastLine_n1, intFound_n1, intLastLine_n1 As Integer
Dim fst_Del_Date, Org_Date, MufCost_Part, MufCost_Tool, Hours_PPP, Part_num, Planer_name, Description As Variant
Dim strFirstAddress As String
Dim searchlast As Range
Dim sht As Worksheet
Dim lastRow As Long
Dim search As Range
Dim FolderNme As String
Dim filepath As String
Dim rngFindValue As Variant
'Yellow
Sub Marine()

MsgBox "Update may take several minutes. Select OK to continue."

'On Error Resume Next
Application.CutCopyMode = False

'Clear Old Data
    Sheets("Data").Select
    Range("A2:I100000").Select
    Selection.ClearContents
    Sheets("Data").Select
    Range("K2:Z100000").Select
    Selection.ClearContents
    Range("A2").Select

Dim Worksheet As Object
Dim Workbook As Object
Dim FldrWkbk As Object
Dim FolderNme As String
Dim filepath As String
Dim OutputRow As Integer
Dim StartRange As String
Dim EndRange As String
Dim ManuCost As Range
Dim searchlast As Range
Dim header As Range, headers As Range
Dim rngMyRange As Object
Dim I As Integer
Dim WS_Count As Integer

WS_Count = ThisWorkbook.Worksheets.Count
strMasterWorkbook = ActiveWorkbook.Name
strImportSheet = "QueryPaths"
strQueryPath = Sheets("QueryLocation").Range("QueryLocation").Value

Sheets(strImportSheet).Select
If Not Range("A1").Value = "" Then
    Cells.Select
    Selection.ClearContents
End If

Workbooks.Open strQueryPath

strLinkWbk = ActiveWorkbook.Name

    Selection.Copy

ThisWorkbook.Activate
Sheets(strImportSheet).Select
Sheets(strImportSheet).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Workbooks(strLinkWbk).Close SaveChanges:=False
'Data--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
With Sheets(strImportSheet)

filepath = strCurrentFilePath
OutputRow = 1
ThisWorkbook.ActiveSheet.Range("A" & OutputRow).Activate
OutputRow = OutputRow + 1
    For intLine = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
        If VBA.Right(.Cells(intLine, 1), 4) = "xlsm" Then
            strCurrentFilePath = "https://fect/" & .Cells(intLine, 5) & "/" & .Cells(intLine, 1)
            dtCurrentFileModified = .Cells(intLine, 2)
            intLoc = 0
            strFileName = ThisWorkbook.Worksheets("QueryPaths").Cells(intLine, 1)
            Set FldrWkbk = Workbooks.Open(strCurrentFilePath, False, True)

            For Each sht In FldrWkbk.Sheets
            ActiveWorkbook.ActiveSheet.Unprotect

              If sht.Name Like "Cal Sheet*" Then
                ThisWorkbook.Worksheets("Data").Range("M" & OutputRow) = WorksheetFunction.Max(Range("Y:Y"))
                ThisWorkbook.Worksheets("Data").Range("N" & OutputRow) = sht.Range("C12")
                ThisWorkbook.Worksheets("Data").Range("T" & OutputRow) = sht.Range("I4")
'------------------------------------CODE IN QUESTION------------------------------------------------------------------------------
                Cells.Find(What:="*Herstellkosten*", LookIn:=xlFormulas).Offset(1, 0).Select
                Set rngMyRange = Selection
                ThisWorkbook.Worksheets("Data").Range("O" & OutputRow) = rngMyRange
                Application.CutCopyMode = False
'------------------------------------CODE IN QUESTION------------------------------------------------------------------------------

              End If

            Next sht
            FldrWkbk.Close SaveChanges:=False
        End If
    Next
End With
'--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' Starting Position
    Sheets("PlannerData").Select
    Range("B2").Select
MsgBox "Update Complete"

End Sub

Answer 1

您应该尽量避免使用Select。请参阅此帖子，了解如何以及为何： How to avoid using Select in Excel VBA macros

至于你的代码，如果找不到任何内容，Find命令将不返回任何内容。我的预测是没有找到任何内容，因此没有选择 new ，因此仍然使用先前的选择。这是使用Select的一个问题！

相反，您应该直接将Find的结果分配到您的范围，然后测试该范围是否为空，如此

' Your Code
Cells.Find(What:="*Herstellkosten*", LookIn:=xlFormulas).Offset(1, 0).Select
Set rngMyRange = Selection
ThisWorkbook.Worksheets("Data").Range("O" & OutputRow) = rngMyRange

' Revised code, without using Select
Set rngMyRange = Cells.Find(What:="*Herstellkosten*", LookIn:=xlFormulas).Offset(1, 0)      
If Not rngMyRange = Nothing Then
    ' Note the use of Value to assign values, rather than making ranges equal (I assume this is your aim?)
    ThisWorkbook.Worksheets("Data").Range("O" & OutputRow).Value = rngMyRange.Value
Else
    ' Some code here for what to do if Data value wasn't found
End If

此外，我还不确定为什么当你没有复制任何东西时你做Application.CutCopyMode = False？这用于清除剪贴板...

编辑：

您还应该完全限定对象。例如，Find语句当前是

Cells.Find(What:="*Herstellkosten*", LookIn:=xlFormulas).Offset(1, 0)

但是Cells ??使用

会好得多

ThisWorkbook.Sheets("SheetName1").Cells.Find(What:="*Herstellkosten*", LookIn:=xlFormulas).Offset(1, 0)

在您的情况下，您将在名为sht的工作表对象上循环，因此它将

sht.Cells.Find(What:="*Herstellkosten*", LookIn:=xlFormulas).Offset(1, 0)

有关完全限定对象的另一个示例，请参阅此SO问题：Qualifying range objects

从目录中的多个工作表和工作簿中查找和选择数据

1 个答案: