Trim Macro to run faster

[leebrooke]

I don't know if i am missing something, but when i run my macro, it is too slow. I have attached the files needed.

Here's how it goes...
1. Open wb1 and let macro run.
2. When userform appears, click on OPEN.
This will allow user to open another workbook, wb2.
3. When wb2 is opened, it automatically copies its columns identical to that of wb1's.

My problem here is that why did it took so long to execute such copying and pasting? Maybe there's a problem somewhere in the macro that needs to be trimmed down for it to run faster.

Kindly help me get this solved. I'd really appreciate it and it would be of great help accomplishing my project. Thank you.

 

[Norie]

Well there is something missing - any attachments.

I'm afraid it's not possible to attach files here.

Why not post the code and/or an example of the data?

For the latter there are various tools to display it in a post, one of which is Colo's HTML maker which you'll find a link for in my sig.

 

[leebrooke]

Im sorry, i unintentionally pressed the Enter key so my post was submitted incompletely. Below is the complete scenario.

Refer to the link below for the files needed.

http://myfreefilehosting.com/f/8fd4c176f9_0.8MB

1. Open wb1 and let macro run.
2. When userform appears, click on OPEN.
This will allow user to open another workbook, wb2.
3. When wb2 is opened, it automatically copies its columns identical to that of wb1's.

My problem here is that why did it took so long to execute such copying and pasting? Maybe there's a problem somewhere in the macro that needs to be trimmed down for it to run faster.

4. After the copying is done, click on FILTER. This will filter some strings on a list file, "strings.LST".
5. After filtering, my macro will prompt the user to save the workbook in a different filename.

I want that when the new workbook is saved, the modules i used for the macro will be deleted, thus creating a saved workbook free from macro.

 

[Norie]

It really would help if you explain in words what the purpose of the code is.

By the way why is Application.ScreenUpdating commented out?

Also I think this could be shortened.

 wbk2.Activate
            wbk2.Sheets(1).Range(Cells(2, m), Cells(2500, m)).Select
            Selection.Copy
            wbk1.Activate
            Sheets(3).Cells(2, tarCol).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

To this.

With wbk2.Sheets(1)
       .Range(.Cells(2, m), .Cells(2500, m)).Copy
End With
 
wbk1.Sheets(3).Cells(2, tarCol).PasteSpecial Paste:=xlPasteValues

 

[leebrooke]

Hi Norie, thank you so much for your quick response.

The Application.ScreenUpdating is supposed to be enabled. I just tried to run the code without it but still no luck. I forgot to remove it as comment when i attached the files.

Below is the explanation of everything in the code.

1. openIt()

  <u1:p> 
</u1:p>      Set wf = WorksheetFunction
<u1:p></u1:p>      Set wbk2 = ActiveWorkbook
  ‘Set range for wb2 in row1, columns A to Z under sheet1
<u1:p></u1:p>      wbk2.Activate
      Set aRange2 = wbk2.Sheets(1).Range("a1", Sheets(1).Range("z1"))
  ‘Set range for wb1 in row1, columns A to Z under sheet3
<u1:p></u1:p>      wbk1.Activate
<u1:p></u1:p>      Set aRange1 = wbk1.Sheets(3).Range("a1", Sheets(3).Range("z1"))
<u1:p></u1:p>      
  ‘This will search for any occurrence of each cell from aRange1 in aRange2
      For Each cell In aRange1
<u1:p></u1:p>          If wf.CountIf(aRange2.Rows(1), cell) > 0 Then
<u1:p></u1:p>              currcell = cell.Address
  ‘get the column where a cell in aRange1 is used
<u1:p></u1:p>              tarCol = cell.Column
  ‘returns the column of aRange2 where the match is found
<u1:p></u1:p>              m = wf.Match(cell, aRange2.Rows(1), 0)
  ‘copy the cells from rows 2-2500 under that column
<u1:p></u1:p>              With wbk2.Sheets(1)
<u1:p></u1:p>                  .Range(.Cells(2, m), .Cells(2500, m)).Copy
<u1:p></u1:p>              End With
  ‘paste the values to the column of the cell in aRange1
<u1:p></u1:p>              wbk1.Sheets(3).Cells(2, tarCol).PasteSpecial Paste:=xlPasteValues
<u1:p></u1:p>              Application.CutCopyMode = False
<u1:p></u1:p>              wbk1.Sheets(3).Columns(tarCol).EntireColumn.AutoFit
<u1:p></u1:p>          End If
<u1:p></u1:p>      Next cell
<u1:p></u1:p>  <u1:p> 
</u1:p>

<u1></u1>2. Filter_list()

<u1></u1>

 On Error Resume Next
<u1:p></u1:p>  <u1:p> 
</u1:p>  Set oWbook = ActiveWorkbook
<u1:p></u1:p>  book = ActiveWorkbook.Name
<u1:p></u1:p>  <u1:p> 
</u1:p>  ‘Initialize the values from rows 3-2500 to some formatting
<u1:p></u1:p>  Set therange = Sheets(3).Range("A3", Sheets(3).Range("A2500"))
<u1:p></u1:p>      therange.EntireRow.Font.ColorIndex = 15 'Gray 15%
<u1:p></u1:p>      therange.EntireRow.Font.Bold = False
<u1:p></u1:p>      therange.EntireRow.Interior.ColorIndex = xlNone
<u1:p></u1:p>  <u1:p> 
</u1:p>  ActiveWindow.WindowState = xlMinimized
<u1:p></u1:p>  <u1:p> 
</u1:p>  ‘Search for any files with extension “.LST” in the same path of wb1
<u1:p></u1:p>  With Application.FileSearch
<u1:p></u1:p>      .NewSearch
<u1:p></u1:p>      'Change path to suit
<u1:p></u1:p>      .LookIn = ActiveWorkbook.Path
<u1:p></u1:p>      .FileType = msoFileTypeAllFiles
<u1:p></u1:p>      .Filename = "*.LST"
<u1:p></u1:p>           
  ‘If list files “.LST” are found, count total number of list files found
<u1:p></u1:p>      If .Execute > 0 Then 'Workbooks in folder
<u1:p></u1:p>          For lCount = 1 To .FoundFiles.Count '  <st1:place u4:st="on">Loop</st1:place> through all.
<u1:p></u1:p>              'Open each list file via loop and Set a Workbook   variable to it
<u1:p></u1:p>              Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
<u1:p></u1:p>              ActiveWindow.WindowState = xlMinimized
<u1:p></u1:p>          Next lCount
<u1:p></u1:p>              oWbook.Activate
<u1:p></u1:p>              On Error Resume Next
  ‘After opening the list files as workbook, loop through each workbook
<u1:p></u1:p>              For Each wBook In Application.Workbooks
  ‘if workbook is wb1, goes to next workbook
<u1:p></u1:p>                  If wBook.Name = book Then GoTo hey
<u1:p></u1:p>                   For Each wSheet In wBook.Worksheets
  ‘set range in wb1, under sheet3 in column B, row 3-2500
<u1:p></u1:p>                      oWbook.Activate
<u1:p></u1:p>                      Set origRange = Sheets(3).Range("b3", Sheets(3).Range("b2500"))
  ‘loop through each cell in origRange, if the font color is other than Gray, it will go to the next cell in origRange.
<u1:p></u1:p>                      For Each cell In origRange
<u1:p></u1:p>                          If Not cell.EntireRow.Font.ColorIndex = 15 Then GoTo yah
<u1:p></u1:p>                          Set rFound = Nothing
  ‘else, used that cell to find in the list file opened as workbook
<u1:p></u1:p>                          Set rFound = wSheet.Cells.Find(What:=cell.Value, After:=wSheet.Cells(1, 1), _
<u1:p></u1:p>                          LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
<u1:p></u1:p>                          SearchDirection:=xlNext, MatchCase:=False)
<u1:p></u1:p>  ‘if a match is found, in the list file, it will get the current row and column of the cell, set entire row to some formatting, and put “YES” to column A (“VALIDITY”).
                          If Not rFound Is Nothing Then
<u1:p></u1:p>                              tarCol = cell.Column
<u1:p></u1:p>                              tarRow = cell.Row
<u1:p></u1:p>                              'cell.Select
<u1:p></u1:p>                              cell.Font.Bold = True
<u1:p></u1:p>                              cell.EntireRow.Font.ColorIndex = 1 'Black
<u1:p></u1:p>                              cell.EntireRow.Interior.ColorIndex = xlNone
<u1:p></u1:p>                              Cells(tarRow, tarCol - 1).Value = "YES"
  ‘if no match is found, in the list file, it will get the current row and column of the cell, set entire row to some formatting, and put “NO” to column A (“VALIDITY”).
<u1:p></u1:p>                          Else
<u1:p></u1:p>                              tarCol = cell.Column
<u1:p></u1:p>                              tarRow = cell.Row
<u1:p></u1:p>                              'cell.Select
<u1:p></u1:p>                              cell.Font.Bold = False
<u1:p></u1:p>                              cell.EntireRow.Font.ColorIndex = 15 'gray
<u1:p></u1:p>                              cell.EntireRow.Interior.ColorIndex = xlNone
<u1:p></u1:p>                              Cells(tarRow, tarCol - 1).Value = "NO"
<u1:p></u1:p>                          End If
<u1:p></u1:p>  yah:
<u1:p></u1:p>                      Next cell
<u1:p></u1:p>                  Next wSheet
<u1:p></u1:p>                  wBook.Close SaveChanges = False
<u1:p></u1:p>  hey:
<u1:p></u1:p>              Next wBook
<u1:p></u1:p>              On Error GoTo 0
<u1:p></u1:p>

Further sample:
openIt() - After wb2 has opened, look for each cell occurrence row1 of wb1 (e.g. English) in row1 of wb2. Since English is found in wb2, copy the cell values in that column to English column in wb1.
<o> </o>
Filter_list() – Open all the list files in the same path as wb1, search for each cell occurrence in ITEM column of wb1 to that of the list files. If there is, reformat entire row and put “YES” in the VALIDITY column in wb1. if none, reformat entire row and put “NO” in the VALIDITY column in wb1.
<o> </o>
I still have to try your code above, thanks....

Hope these helps, Norie. My only problem so far is the total time it take to run the macro, and also, i don't know how to remove the modules to be saved in the new workbook.

<!--[if !supportLineBreakNewLine]-->
<!--[endif]-->
<u1></u1>