Finding and selecting data from many sheets and workbooks in a directory

Question

I am creating a macro that will open each workbook in a directory and pull data into my new workbook based on a few factors like file type and sheet names. Most all of this data I can pull in based on its location on the sheet, however I have one where I need to pull the value directly below a header that has changed position many times between versions. Currently, it will successfully find the correct value and put it where it is intended to go in my original workbook. However, when multiple sheets exists in the workbook that match my criteria, it will just repeat the first value found on the first sheet rather than executing the search and giving me the value from each individual sheet. Code below with the section in question marked. Any ideas how I can solve this would be much appreciated!

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

BTW, you don't need to select that Range, and you don't need CutCopyMode = False because you simply assign the value of one cell to another. — z32a7ul, Mar 22 '17 at 11:28

score 0 · Answer 1 · edited May 23 '17 at 11:46

You should try and avoid using Select. See this post on how and why: How to avoid using Select in Excel VBA macros

As for your code, the Find command will return nothing if nothing was found. My prediction is that nothing is found, so nothing new is selected, so the previous selection is still used. This is one problem from using Select!

Instead you should directly assign the result of Find to your range, then test if that range is nothing, like so

' 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

Also, I'm not sure why you did Application.CutCopyMode = False when you haven't copied anything? This is used to clear the clipboard...

Edit:

You should also fully qualify your objects. For instance, the Find statement is currently

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

But where are the Cells?? It would be much better to use

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

In your case, you're cycling over sheet objects, called sht, so it would be

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

See this SO question for another example of fully qualifying objects: Qualifying range objects

Sorry I copy elsewhere in the code, I just forgot to remove it when I was cutting things down for the post. Thank you, this is certainly a better way, however I am still not getting the values I should be. I am getting the same value from the first worksheet 5 times when there are 5 different values on five qualifying worksheets that I need to see... — brianabrownesq, Mar 22 '17 at 12:39

Finding and selecting data from many sheets and workbooks in a directory

1 Answers1