Dear Friends,

First of all I thank all of you in advance for taking time to help
other people out :)

My Macro is a complex function involving Vlookups and a lot of
processing of data.

It works fine for me and correctly does what I wrote it for. But the
problem im facing is a different one.

PROBLEM:
       The Problem is that it is TOO HEAVY on the Processor. My
computer has a Genuine Intel Processor (2.0 GHz) and 2GB of RAM. But
as soon as I run the Macro, the Processor Load shoots up to above 85%
and it take about 3 to 5 minutes to process a SINGLE file. And as I
have to run it on Multiple files( automatically but ... one by one) it
take tooooo long to run.

THE HELP THAT I EXPECT from you people is that please read the
code ... and if at any segment of code you think that it can be done
in a simpler way. Please suggest that to me.

I know it will be a time-taking excerise .... BUT ... you need not do
all of it together. You can just read one part of the code and improve
it and paste the reply (kindly copy the actual code segment too, so
that I know which part you have helped me better). And thus you can
help me improve it in a few attempts.

I thank ALL of you in advance for taking time to help me...

Looking forward to you help..

Thanks a lot
~~~~~~~~~~~~~~~~~~  Code  ~~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Sub Huawei()
'
' TEST2 Macro
' Macro recorded 3/30/2007 by alishe
'
'
   Dim MyArray(8)
   Dim i As Long
   Dim Check As Integer
   Dim LastRow As Long
   Dim lastcolumn As Long
   Dim My_Date As String
   Dim File_Name As String
   Dim Start_Date as date

   ' Variables For Checking New Cells
   Dim First_Entry As Integer
   Dim Filtered_Record_Count As Long

   MyArray(1) = "Sum of available TRX in the cell"
   MyArray(2) = "Available TCHs"
   MyArray(3) = "TCH congestion rate (TCH overflow)(%)"
   MyArray(4) = "TCH traffic volume (excluding very early assignment)
(ERL)"
   MyArray(5) = "Start Time"
   MyArray(6) = "Managed Element"
   MyArray(7) = "Cell(GSM)"

   Workbooks.Open Filename:="C:\Ali\Stats_Huawei
\Huawei_Stats_Cell_IDs.xls"

        Start_Date = InputBox("Please Enter the Starting date: ",
"Start Date", "5/19/2007")

    File_Name = "Huawei_cell_" & Format(Day(Start_Date) + Days_Ctr,
"00") & Format(Month(Start_Date), "00") & Format(Year(Start_Date),
"0000") & ".csv"

        Application.ScreenUpdating = False

        Workbooks.Open Filename:="C:\Ali\Stats_Huawei\" & File_Name

        GoSub Select_My_Columns

        GoSub Get_Site_ID

        Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Windows("Factory.xls").Activate
        ActiveSheet.Paste
        Selection.End(xlDown).Select
        ActiveCell.Offset(1, 0).Select
        Application.CutCopyMode = False
        Windows(File_Name).Activate

        ActiveWindow.Close SaveChanges:=False

        Windows("Factory.xls").Activate 'Re Activating the FACTORY
FILE
        Application.CutCopyMode = False

        GoSub Del_Blank_Rows

        Range("H2").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.End(xlDown).Select
        LastRow = ActiveCell.Row

        With Sheets(1).Range("I2:Q2")
            .AutoFill Destination:=Range("I2:Q" & LastRow&)
        End With

        GoSub Remove_Hash

        GoSub Del_Zero_Sites

        GoSub Cut_Sides

        GoSub First_Row_Char

        Application.ScreenUpdating = True

        My_Date = Format(Year(Range("D3")), "0000") & "_" &
Format(Month(Range("D3")), "00") & "_" & Format(Day(Range("D3")),
"00")

        ChDir "C:\Ali\Stats_Huawei"
        ActiveWorkbook.SaveAs Filename:= _
            "C:\Ali\Stats_Huawei\" & My_Date & "_Huawei.xls",
FileFormat:= _
            xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False _
            , CreateBackup:=False

        ActiveWindow.Close SaveChanges:=False
        Windows(File_Name).Close

   Windows("Huawei_Stats_Cell_IDs.xls").Close

   Response = MsgBox("    Success ... !", 0, " Message  ")

   Exit Sub

'********************************** SUB ROUTINES
****************************************

Select_My_Columns:

For i = 1 To 7

   Cells.Find(What:=MyArray(i), after:=ActiveCell, LookIn:=xlValues,
LookAt:= _
       xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:=False _
       , SearchFormat:=False).Activate
   Columns(ActiveCell.Column).Select
   Selection.Cut
   Columns("A:A").Select
   Selection.Insert Shift:=xlToRight

Next i

'Deleting Columns

   Columns("H:H").Select
   Range(Selection, Selection.End(xlToRight)).Select
   Selection.Delete Shift:=xlToLeft

'Deleting Rows
   Range("A2").Select
   Range(Selection, Selection.End(xlDown)).Select
   Selection.End(xlDown).Select
   ActiveCell.Offset(1, 0).Activate
   LastRow = ActiveCell.Row
   Rows(LastRow).Select
   Range(Selection, Selection.End(xlDown)).Select
   Selection.Delete Shift:=xlUp

Range("A2").Select

Return

' GET SITE ID
****************************************************************

Get_Site_ID:

   Windows(File_Name).Activate
   Columns("B:B").Select 'Inserting two columns at 2nd and 3rd Place
   Selection.Insert Shift:=xlToRight
   Columns("B:B").Select
   Selection.Insert Shift:=xlToRight

Range("B2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],
[Huawei_Stats_Cell_IDs.xls]Sheet1!R2C1:R65536C3,2,FALSE)"

Range("C2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],
[Huawei_Stats_Cell_IDs.xls]Sheet1!R2C1:R65536C3,3,FALSE)"

Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.End(xlDown).Select
LastRow = ActiveCell.Row

With Sheets(1).Range("B2:C2")
   .AutoFill Destination:=Range("B2:C" & LastRow&)
End With

Range("B2:C2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False

GoSub Check_New_Cells

Columns("A:A").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("A2").Select

Return

' REMOVE # SIGNS
****************************************************************

Remove_Hash:

   Check = 0

   Do While 1 = 1

       Cells.Find(What:="#", after:=ActiveCell, LookIn:=xlValues,
LookAt:= _
           xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:=False _
           , SearchFormat:=False).Activate

       On Error GoTo ErrorHandler

       If Check = 1 Then
       Exit Do
       End If

       ActiveCell.Select
       ActiveCell.FormulaR1C1 = "0"

   Loop

ErrorHandler:
         Check = 1
          Resume Next

   Return

' CUT SIDES CODE
****************************************************************

Cut_Sides:

'Deleting Columns

   Range("A2").Select
   Range(Selection, Selection.End(xlToRight)).Select
   Selection.End(xlToRight).Select
   ActiveCell.Offset(0, 1).Activate
   lastcolumn = ActiveCell.Column
   Columns(lastcolumn).Select
   Range(Selection, Selection.End(xlToRight)).Select
   Selection.Delete Shift:=xlToLeft

'Deleting Rows
   Range("A2").Select
   Range(Selection, Selection.End(xlDown)).Select
   Selection.End(xlDown).Select
   ActiveCell.Offset(1, 0).Activate
   LastRow = ActiveCell.Row
   Rows(LastRow).Select
   Range(Selection, Selection.End(xlDown)).Select
   Selection.Delete Shift:=xlUp

   Return

' FIRST ROW BEGINS WITH CHARACTER
****************************************************

First_Row_Char:

       Cells.Find(What:="MD", after:=ActiveCell, LookIn:=xlValues,
LookAt:= _
           xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:=False _
           , SearchFormat:=False).Activate
   Rows(ActiveCell.Row).Select
   Selection.Cut
   Rows(2).Select
   Selection.Insert Shift:=xlDown

   Range("A2").Select

   Return

' DELETE ROWS WITH BLANK ENTRIES
*****************************************************
Del_Blank_Rows:

For J = 1 To 8
   Columns(J).Select
   On Error Resume Next
   Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Next

Return

' DELETE ROWS WITH ZERO Entries in first Two Columns
********************************
Del_Zero_Sites:

For J = 1 To 2
   'Columns(J).Select
   Columns(J).Replace 0, "", xlWhole
   On Error Resume Next
   Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Next

Return

'CHECKS NEW CELLS WITH NON-ZERO UTILIZATION IN HUAWEI LIST AND
DISPLAYS THEM.
'IN CASE OF NO NEW CELL FOUND, IT CONTINUES .... OTHERWISE DISPLAYS
THEM AND QUITS.

Check_New_Cells:
   Application.ScreenUpdating = False
   Range("J1").Value = "Sum"
   Range("K1").Value = "Unique Records"

   Rows(1).Select
   Selection.AutoFilter

   'Deleting Columns

   Columns("L:L").Select
   Range(Selection, Selection.End(xlToRight)).Select
   Selection.Delete Shift:=xlToLeft

'Deleting Rows
   Range("A2").Select
   Range(Selection, Selection.End(xlDown)).Select
   Selection.End(xlDown).Select
   ActiveCell.Offset(1, 0).Activate
   LastRow = ActiveCell.Row
   Rows(LastRow).Select
   Range(Selection, Selection.End(xlDown)).Select
   Selection.Delete Shift:=xlUp

   Range("A2").Select

   Selection.AutoFilter Field:=2, Criteria1:="#N/A"

   Range("B2").Select
   GoSub Next_Visible_Row
   First_Entry = ActiveCell.Row
   ActiveCell.Offset(0, 8).Activate

   ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,RC[-4]:RC[-1])"

   Cells(First_Entry, 10).Select
   Range("J2:J" & LastRow - 1&).Select
   Selection.FillDown

   Rows(1).Select      ' REMOVE FILTERS ... I.E. SHOW ALL
   Selection.AutoFilter

   Columns(10).Select

   Selection.Copy
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False

   Rows(1).Select      'Autofilter
   Selection.AutoFilter

   Selection.AutoFilter Field:=2, Criteria1:="#N/A"
   Selection.AutoFilter Field:=10, Criteria1:="<>0", Operator:=xlAnd

   Range("J2").Select
   GoSub Next_Visible_Row
   First_Entry = ActiveCell.Row
   Cells(First_Entry, 11).Select
   ActiveCell.FormulaR1C1 =
"=IF(COUNTIF(R2C1:RC[-10],RC[-10])=1,RC[-10],"""")"
   Range("K2:K" & LastRow - 1&).Select
   Selection.FillDown

   GoSub Get_Record_Count

   If Filtered_Record_Count = 0 Then

       Workbooks.Open Filename:="C:\Ali\Stats_Huawei\Factory.xls"
       Range("A2").Select

       Windows(File_Name).Activate

       Rows(1).Select      ' REMOVE FILTERS ... I.E. SHOW ALL
       Selection.AutoFilter

       'Deleting Columns

       Columns("J:J").Select
       Range(Selection, Selection.End(xlToRight)).Select
       Selection.Delete Shift:=xlToLeft

       'Deleting Rows
       Range("A2").Select
       Range(Selection, Selection.End(xlDown)).Select
       Selection.End(xlDown).Select
       ActiveCell.Offset(1, 0).Activate
       LastRow = ActiveCell.Row
       Rows(LastRow).Select
       Range(Selection, Selection.End(xlDown)).Select
       Selection.Delete Shift:=xlUp

       Range("A2").Select

   Else
       Columns(11).EntireColumn.AutoFit

       Windows("Huawei_Stats_Cell_IDs.xls").Close
       'Windows(File_Name).Close

       Application.ScreenUpdating = True
       Response = MsgBox("There are " & Filtered_Record_Count & " New
Cells. Please Update ID List...", vbOKOnly, "Ali, RF")
       Exit Sub

   End If

Return

' GET NUMBER OF ROWS IN FILTERED DATA
************************************
' IMPORTANT : THIS FUNCTION IS NOT GENERIC ... ITS HAS BEEN CUSTOMIZED
FOR THIS MODULE

Get_Record_Count:
   matched_criteria = 0                         ' Set variable to
zero.

   check_row = 0                                ' Set variable to
zero.

   Cells(First_Entry, 11).Select

   While Not ActiveCell.Value = ""            ' Check to see if row
                                            ' height is zero.

       If ActiveCell.RowHeight = 0 Then
           check_row = check_row + 1
       Else
           matched_criteria = matched_criteria + 1

        '********** Formatting Start ***********
   With Selection.Interior
       .ColorIndex = 40
       .Pattern = xlSolid
   End With
   With Selection
       .HorizontalAlignment = xlCenter
       .VerticalAlignment = xlBottom
       .WrapText = False
       .Orientation = 0
       .AddIndent = False
       .IndentLevel = 0
       .ShrinkToFit = False
       .ReadingOrder = xlContext
       .MergeCells = False
   End With
   Selection.Borders(xlDiagonalDown).LineStyle = xlNone
   Selection.Borders(xlDiagonalUp).LineStyle = xlNone
   With Selection.Borders(xlEdgeLeft)
       .LineStyle = xlContinuous
       .Weight = xlThin
       .ColorIndex = xlAutomatic
   End With
   With Selection.Borders(xlEdgeTop)
       .LineStyle = xlContinuous
       .Weight = xlThin
       .ColorIndex = xlAutomatic
   End With
   With Selection.Borders(xlEdgeBottom)
       .LineStyle = xlContinuous
       .Weight = xlThin
       .ColorIndex = xlAutomatic
   End With
   With Selection.Borders(xlEdgeRight)
       .LineStyle = xlContinuous
       .Weight = xlThin
       .ColorIndex = xlAutomatic
   End With

          '********* Formatting End **********
           ActiveCell.Offset(1, 0).Select
       End If
       GoSub Next_Visible_Row
   Wend

   Filtered_Record_Count = matched_criteria

Return

' SELECT NEXT VISIBLE ROW (IN FILTERED DATA)
************************************
Next_Visible_Row:
   Do While ActiveCell.EntireRow.Hidden = True
   ActiveCell.Offset(1, 0).Select
   Loop
Return
'********************************** SUB ROUTINES ENDS
*********************************

End Sub

~~~~~~~~~~~~~~~ End of Code ~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~