Results 1 to 4 of 4

Help optimizing this code

Threaded View

  1. #1
    Registered User
    Join Date
    08-01-2021
    Location
    London
    MS-Off Ver
    365
    Posts
    5

    Post Help optimizing this code

    Hello,

    This code opens a new workbook, loops throughout all excel workbooks in a folder, opens the first one, loops throughout the cells of the table of the first worksheet and if the conditional formatting color is the desired, copies the cell value from the first column which is an ID to the new workbook.

    It's basically so I can know what IDs are still undone in all the files.

    It works but as more files are added to the folder, the slower it gets (at the beginning I call another subprocedure to turn things off like events, screen updating and so on which I ommited here). It's still faster than checking manually each file but maybe it can be optimized somehow. I thought of trying with an array but don't know exactly how I could do it.

    Sub importPendingCases()
    
    Dim newWbk As Workbook
    Set newWbk = Workbooks.Add
    
    Dim newWks As Worksheet
    Set newWks = newWbk.Sheets(1)
    
    Dim MyFiles As String
    
    MyFiles = Dir("FolderPath*.xlsx.lnk")
    
    Do While MyFiles <> ""
        
        Dim wbk As Workbook
        Set wbk = Workbooks.Open("FolderPath" & MyFiles, False, False)
        wbk.Activate
        
        Dim wks As Worksheet
        Set wks = wbk.Sheets(1)
    
        Dim tbl As ListObject
        Set tbl = wks.ListObjects("Table1")
        
        Dim rng As Range
        Set rng = tbl.DataBodyRange
        
        With rng
        
            Dim tRows As Long
            tRows = .Rows.Count
        
        End With
        
        Dim r As Long
                    
        For r = 1 To tRows
        
            Dim c As Range
            
            For Each c In rng.Cells(r, 1)
            
                If c.DisplayFormat.Interior.Color = 45559 Then
                    
                    Dim lastRow As Long
                    
                    lastRow = newWks.Cells(Rows.Count, 1).End(xlUp).Row
                    
                    newWks.Range("A" & lastRow + 1).Value = wks.Range("A" & r + 1).Value
                
                End If
                
             Next c
        
        Next r
    
        wbk.Close False
    
        MyFiles = Dir
        
    Loop
    
    End Sub
    Last edited by mike-lowski; 08-02-2021 at 08:43 AM.

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. Need Help Optimizing Code
    By joey2point0 in forum Excel Programming / VBA / Macros
    Replies: 8
    Last Post: 10-25-2017, 03:29 PM
  2. Optimizing Code
    By tucanj in forum Excel Programming / VBA / Macros
    Replies: 2
    Last Post: 02-04-2013, 11:08 PM
  3. Optimizing Code
    By dcgrove in forum Excel Programming / VBA / Macros
    Replies: 1
    Last Post: 10-23-2012, 11:20 AM
  4. Optimizing the code
    By kmlprtsngh in forum Excel Programming / VBA / Macros
    Replies: 3
    Last Post: 12-10-2010, 01:27 AM
  5. Optimizing the Vlookup code in VB. Repitive code with different referencing range.
    By raknahs in forum Excel Programming / VBA / Macros
    Replies: 2
    Last Post: 07-23-2010, 05:03 PM
  6. Optimizing code
    By randell.graybill in forum Excel Programming / VBA / Macros
    Replies: 2
    Last Post: 10-06-2009, 11:40 PM
  7. [SOLVED] Optimizing Code
    By Jim Thomlinson in forum Excel Programming / VBA / Macros
    Replies: 5
    Last Post: 03-02-2005, 10:11 PM

Tags for this Thread

Bookmarks

Posting Permissions

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

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1