Results 1 to 2 of 2

Thread: Use VBA to run a code on multiple excel files yet each doesn't save a new sheet

  1. #1

    Thread Starter
    Registered User
    Join Date
    Jun 2021
    Posts
    1

    Use VBA to run a code on multiple excel files yet each doesn't save a new sheet

    Hi, I am super new to VBA language and I am trying to fix my code.
    I want to run my macro on multiple files and I have found a code to so. My macro is to find certain rows based on keywords and save them on a new sheet.
    Yet when I run on multiple files, it doesn't have the new sheet.
    If better, is there a way to save the found rows from all excel workbooks in the folder into one new workbook?
    Here is my code. Really appreciate the help

    Code:
    Sub LoopAllExcelFilesInFolder()
    'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
    
    Dim wb As Workbook
    Dim myPath As String
    Dim myFile As String
    Dim myExtension As String
    Dim FldrPicker As FileDialog
    Dim strArray As Variant
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim NoRows As Long
    Dim DestNoRows As Long
    Dim I As Long
    Dim J As Integer
    Dim rngCells As Range
    Dim rngFind As Range
    Dim Found As Boolean
    '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 = "*.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
        
        strArray = Array("stent", "Stent") 'put your keywords here'
        Set wsSource = wb.Sheets(1)
         wsSource.Select
        Set wsSource = ActiveSheet 'just open one worksheet'
        
        NoRows = wsSource.Range("A65536").End(xlUp).Row
        DestNoRows = 1
        Set wsDest = ActiveWorkbook.Worksheets.Add
            
        For I = 1 To NoRows
        
            Set rngCells = wsSource.Range("D" & I & ":D" & I) 'specify range in the parentheses, if only want to search one column, put from D to D'
            Found = False
            For J = 0 To UBound(strArray)
                Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
            Next J
            
            If Found Then
                rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
                
                DestNoRows = DestNoRows + 1
            End If
        Next I
        'Save and Close Workbook
          wb.Close SaveChanges:=True
          
        'Ensure Workbook has closed before moving on to next line of code
          DoEvents
    
        'Get next file name
          myFile = Dir
      Loop
    
    'Message Box when tasks are completed
      MsgBox "Task Complete!"
    
    ResetSettings:
      'Reset Macro Optimization Settings
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    
    End Sub

  2. #2
    PowerPoster
    Join Date
    Dec 2004
    Posts
    25,618

    Re: Use VBA to run a code on multiple excel files yet each doesn't save a new sheet

    Set wsSource = wb.Sheets(1)
    wsSource.Select
    Set wsSource = ActiveSheet 'just open one worksheet'

    NoRows = wsSource.Range("A65536").End(xlUp).Row
    DestNoRows = 1
    Set wsDest = ActiveWorkbook.Worksheets.Add
    you should avoid selecting anything or using active anything, to prevent errors, especially when working with multiple workbooks

    try like
    Code:
        Set wsSource = wb.Sheets(1)
         Set wsSource = wb.sheets(1)'just open one worksheet'
        
        NoRows = wsSource.Range("A65536").End(xlUp).Row
        DestNoRows = 1
        Set wsDest = wb.Worksheets.Add
    If better, is there a way to save the found rows from all excel workbooks in the folder into one new workbook?
    yes of course this is quite possible
    change the last line above to
    Code:
    set wsdest = workbooks.add.sheets(1)
    you should move that line to above the start of the loop opening files, also the line setting destnorows =1
    make sure to save and close the new workbook after the loop
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width