Open a workbook in a directory,filter the data based on criteria,copy the filtered data in a different workbook,automating daily office work using VBA,VBA teacher Sourav,Kolkata 09748184075

Option Explicit




Sub LoopAllExcelFilesInFolder()

'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim N As Long
'First trying to close the file if it is already open
On Error Resume Next

Workbooks("data.xlsm").Close SaveChanges:=True

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "data.xls*"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(FileName:=myPath & myFile)
   
    'Ensure Workbook has opened before moving on to next line of code
      DoEvents
   
    'Change First Worksheet's Background Fill Blue
      wb.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)
     
      'Let's try the autofiltering
        ActiveWorkbook.Sheets("Sheet1").Activate
     
      
        On Error Resume Next
   
        ActiveWorkbook.ActiveSheet.ShowAllData
  
        ActiveSheet.Range("A1").AutoFilter Field:=35, Criteria1:= _
        "August 2015"
       
       
     
        N = Range("AI" & Rows.count).End(xlUp).Row
        Range("AI2:AI" & N).Select
        Selection.Copy
    'Save and Close Workbook
      wb.Close SaveChanges:=True
     
        'now let's see if the workbook where the filtered data to be pasted is open or not
       
         Dim status As Boolean

         status = IsWorkBookOpen("C:\Users\sourav\Desktop\filter_final_RD.xlsx")
         If status = False Then

         Workbooks("C:\Users\sourav\Desktop\filter_final_RD.xlsx").Open
         End If
        
         Workbooks("C:\Users\sourav\Desktop\filter_final_RD.xlsx").Activate
         ActiveWorkbook.Sheets("DATABASE").Select
         Range("AJ3").Select
         ActiveSheet.Paste
        
       
         Application.CutCopyMode = False
         wb.Activate
        
        

     
    'Ensure Workbook has closed before moving on to next line of code
      DoEvents

    'Get next file name
      myFile = Dir
  Loop

'Let/'s try the filtering

'Message Box when tasks are completed
  MsgBox "Task Complete!"

 Workbooks("C:\Users\sourav\Desktop\filter_final_RD.xlsx").Activate
         ActiveWorkbook.Sheets("DATABASE").Select
ActiveWorkbook.Save

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True



End Sub

Function IsWorkBookOpen(FileName As String)
    Dim ff As Long, ErrNo As Long

    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0

    Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function