Macro code that wil look in another workbood to find a date, and average two cells for return answer

[tbrenner]

Hi, I am working on a piece of code that will locate a date on another workbook "that date is the value of a formula". Once it has located the date, I need it to average two cells that are located 4 columns over on same row and the cell below that one. I would like the answer to be zero, if the date is not found. The following code does not work.

        'searches for date plus 3 days and copies the two cells to the right.
        Set three1 = wsmf.Cells.Find(What:=thday, After:=Range("A1")).Offset(0, 4).Resize(, 1)
        three1.Copy
        'ws.Range("P10").PasteSpecial xlPasteValues
        Set three2 = wsmf.Cells.Find(What:=thday.Date, After:=Range("A1")).Offset(1, 4).Resize(, 1)
        three2.Copy
        'ws.Range("P10").Value = three2
        rng = WorksheetFunction.Average(three1, three2)
        rng.Copy
 
        'pastes the information in the last row of your spreadsheet
        Windows("640109 Average.xlsx").Activate
        Set ws = ActiveWorkbook.Sheets(1)
        lngLastRow1 = ws.Range("C65536").End(xlUp).Row + 1
        ws.Range("C" & lngLastRow1).PasteSpecial xlPasteValues
        ws.Range("P" & lngLastRow1).Value = FilePath
        Application.CutCopyMode = False

 

[JLGWhiz]

Could be because your Resize(. 1) statement doesn't resize anything Try modifying these lines:

Set three1 = wsmf.Cells.Find(What:=thday, After:=Range("A1")).Offset(0, 4).Resize(, 1)
        three1.Copy
        'ws.Range("P10").PasteSpecial xlPasteValues
        Set three2 = wsmf.Cells.Find(What:=thday.Date, After:=Range("A1")).Offset(1, 4).Resize(, 1)
        three2.Copy

To This:

Set three1 = wsmf.Cells.Find(What:=thday, After:=Range("A1")).Offset(0, 4).Resize(2, 1)
        three1.Copy
        'ws.Range("P10").PasteSpecial xlPasteValues
        Set three2 = wsmf.Cells.Find(What:=thday.Date, After:=Range("A1")).Offset(1, 4).Resize(2, 1)
        three2.Copy

Also, you have a copy command for each variable but not paste. You might want to comment those two lines out.

 

[tbrenner]

JLGWhiz, Thanks for the help. That code was just a snip of what isn't working in the full macro. I need to average the two cells from the other workbook, either before it pulls the data or after. The above code I was trying to pull the value from each cell and average them to past that answer in the active workbook. How do you average two cells from another workbook, and have a single value to give to the active workbook.

The full macro asks you to pick a example file that it will use a portion of the file name to search for files with in the name. It asks you for the directory you would like to search. Once it finds the first file it will find the work "Date" and past the information one cell to the right on my active workbook. That "date" will be used to find the next three dates I need, by adding 3day, 7day, 28day to it. Once it finds the "Date + 3" it will average the data from a two cells 4 column's down on that row and just below it. I can't change the sheets that I am collecting information from, so it will have to search for data based on the data that will always be present. Not sure how to attach example files or if that is allowed, but most of the code at the bottom to help with the full scope of the project.

Below is the code that pulls the data from each cell that I want the average, should both cells be pulled and averaged in one "cells.find" command?

'searches for "Date + 3days" and copies the two cells to the right.   
        'Set three1 = wsmf.Cells.Find(What:=thday, After:=Range("A1")).Offset(0, 4).Resize(, 1)
        'three1.Copy
        'below line was used for checking the collected data
        'ws.Range("P10").PasteSpecial xlPasteValues
        'Set three2 = wsmf.Cells.Find(What:=thday.Date, After:=Range("A1")).Offset(1, 4).Resize(, 1)
        'three2.Copy
        'ws.Range("P10").Value = three2
        'rng = WorksheetFunction.Average(three1, three2)
        'rng.Copy
   
        'pastes the information in the last row of your spreadsheet
        Windows("640109 Average.xlsx").Activate
        Set ws = ActiveWorkbook.Sheets(1)
        lngLastRow1 = ws.Range("C65536").End(xlUp).Row + 1
        ws.Range("C" & lngLastRow1).PasteSpecial xlPasteValues
        ws.Range("P" & lngLastRow1).Value = FilePath
        Application.CutCopyMode = False

Sub FindTotalJobs()
Dim path As String
Dim FileName As String
Dim Wkb As Workbook
Dim wsmf As Worksheet
Dim lngLastRow1 As Long
Dim wkb1 As Workbook
Dim rng As Range
'This prompts me to pick the filename with an example with the numbers I will be searching for
Dim Flpath As String
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
If .Show = False Then Exit Sub
Flpath = .SelectedItems(1)
End With
'This prompts me to pick a directory to search for files meeting the filename
Dim Fpath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = False Then Exit Sub
Fpath = .SelectedItems(1)
End With
    
'This strips the filename from the full path
sFileName = Mid(Mid(Flpath, InStrRev(Flpath, "/") + 1), InStrRev(Flpath, "\") + 1)
  
    
Call ToggleEvents(False)
    'this sets the worksheet I need the data on as active
    Set ws = ActiveWorkbook.Sheets(1)
    'this strips the un-needed parts of the file name away
    nfname = Left(sFileName, InStr(sFileName, " ") - 1)
    'I used this to verify what part of the filename was used for searching
    'ws.Range("J1").Value = nfname
    '###################################
    path = Fpath  'Change as needed
    '###################################
    FileName = Dir(path & "\" & nfname & "*.xls*", vbNormal)  'Change as needed (Are you looking for xls or xlsx files?)
    
    'I think this allows this to cycle until all files that meet the need are accounted for
    Do Until FileName = ""
        
        'this opens the workbook in the above specified folder
        Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName, _
            UpdateLinks:=0, _
              ReadOnly:=True, _
              AddToMRU:=False)
               
        'set this to the sheet number to look at
        Set wsmf = Wkb.Sheets(1) ' Use this line if want first sheet every time
        
        'moves to next spreadsheet if "Needed Data" is not found
        On Error GoTo NotFound
         
        'searches for "Date" and copies the two cells to the right.
        Set rng = wsmf.Cells.Find(What:="Date", After:=Range("A1")).Offset(0, 1).Resize(, 1)
        'Application.Average(Selection) = rng
        rng.Copy
        
        'These take the found Date and add to them for the next Date to find.
        thday = DateAdd("d", 3, rng)
        sday = DateAdd("d", 7, rng)
        twday = DateAdd("d", 28, rng)
        'ws.Range("J1").Value = thday

        'pastes the information in the last row of your spreadsheet
        Windows("640109 Average.xlsx").Activate
        Set ws = ActiveWorkbook.Sheets(1)
        lngLastRow1 = ws.Range("A65536").End(xlUp).Row + 1
        ws.Range("A" & lngLastRow1).PasteSpecial xlPasteValues
        ws.Range("P" & lngLastRow1).Value = FilePath
        Application.CutCopyMode = False
              
        'searches for "Ticket" and copies the two cells to the right.
        Set rng = wsmf.Cells.Find(What:="Truck / Ticket #", After:=Range("A1")).Offset(0, 2).Resize(, 1)
        rng.Copy
        'pastes the information in the last row of your spreadsheet
        Windows("640109 Average.xlsx").Activate
        Set ws = ActiveWorkbook.Sheets(1)
        lngLastRow1 = ws.Range("B65536").End(xlUp).Row + 1
        ws.Range("B" & lngLastRow1).PasteSpecial xlPasteValues
        ws.Range("P" & lngLastRow1).Value = FilePath
        Application.CutCopyMode = False
        
        'searches for "Average" and copies the two cells to the right.
        'Set three1 = wsmf.Cells.Find(What:=thday, After:=Range("A1")).Offset(0, 4).Resize(, 1)
        'three1.Copy
        'below line was used for checking the collected data
        'ws.Range("P10").PasteSpecial xlPasteValues
        'Set three2 = wsmf.Cells.Find(What:=thday.Date, After:=Range("A1")).Offset(1, 4).Resize(, 1)
        'three2.Copy
        'ws.Range("P10").Value = three2
        'rng = WorksheetFunction.Average(three1, three2)
        'rng.Copy
   
        'pastes the information in the last row of your spreadsheet
        Windows("640109 Average.xlsx").Activate
        Set ws = ActiveWorkbook.Sheets(1)
        lngLastRow1 = ws.Range("C65536").End(xlUp).Row + 1
        ws.Range("C" & lngLastRow1).PasteSpecial xlPasteValues
        ws.Range("P" & lngLastRow1).Value = FilePath
        Application.CutCopyMode = False


            'check to make sure the pasted cells have values
            'if no value present, place zeros in the cells
            If Len(ws.Range("C" & lngLastRow1).Value) + Len(ws.Range("E" & lngLastRow1).Value) + Len(ws.Range("G" & lngLastRow1).Value) = 0 Then
                ws.Range("C" & lngLastRow1).Value = 0
                ws.Range("E" & lngLastRow1).Value = 0
                ws.Range("G" & lngLastRow1).Value = 0
            End If
    
NotFound:
    If Err.Number > 0 Then
        Windows("640109 Average.xlsx").Activate
        Set ws = ActiveWorkbook.Sheets(1)
        lngLastRow1 = ws.Range("A65536").End(xlUp).Row + 1
        ws.Range("P" & lngLastRow1).Value = FilePath
        ws.Range("C" & lngLastRow1).Value = 0
        ws.Range("E" & lngLastRow1).Value = 0
        ws.Range("G" & lngLastRow1).Value = 0
    End If
    
    Err.Clear
    
    FileName = Dir()
    
    Wkb.Close
    
    Loop
Call ToggleEvents(True)
End Sub
Sub ToggleEvents(blnState As Boolean)
'Originally written by firefytr
    
    With Excel.Application
        .DisplayAlerts = blnState
        .EnableEvents = blnState
        .ScreenUpdating = blnState
        If blnState Then .CutCopyMode = False
        If blnState Then .StatusBar = False
    End With
    
End Sub