Making Code More Efficient

A

alishehzad

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 ~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
D

Don Guillett

1st. Try to remove selections where possible. RARELY needed for anything
Range("H2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.End(xlDown).Select
LastRow = ActiveCell.Row
Could probably be one line without selections.

lastrow=cells(rows.count,"H").end(xlup).row+1
rows("2:" & lastrow).delete

2. Once workbooks are open, it is not necessary to
copy>activate>paste>goback
instead the ONE line
sheets("source").range("a1").copy
workbooks("destination").sheets("yoursheet").range("a1")
3. borders could be a one liner also
Worksheets("sheet1").Range("A1:d4").Borders.LineStyle = xlContinuous
4. Lot's of other things. It appears you need professional help.
--
Don Guillett
SalesAid Software
(e-mail address removed)
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 ~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Click to expand...
 
A

alishehzad

Thanks a lot Don,

I'll try to incorporate all the things you said. When ever you have
time ... please come back and suggest more.

As I said earlier, its not going to be done in one Reply. But when
ever you feel like ... kindly help me out.

Thanks a lot ... once more.

And Other experts are also welcome to give their suggestions. I'll be
waiting for it ...

Rgrds,
 
D

Dana DeLouis

Hi. This doesn't cause a problem with speed, but you may like the
following:

My_Date = Format([D3], "yyyy_mm_dd")

Instead of:

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


Another variation on another section.
My personal preference is to use Replace on a long complex string.

Const Huawei_FileName As String = "Huawei_cell_#.csv"
'then later...
Start_Date = Now()
Filename = Replace(Huawei_FileName, "#", Format(Start_Date, "ddmmyyyy"))

Instead of:
file_name = "Huawei_cell_" & Format(Day(Start_Date) + Days_Ctr,
"00") & Format(Month(Start_Date), "00") & Format(Year(Start_Date),
"0000") & ".csv"

Maybe:
Range(Range("H1"), Range("H1").End(xlToRight)).EntireColumn.Delete

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


Maybe:
Columns("B:C").Insert
Instead of:

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

Maybe:
Columns("A:A").Delete

Instead of:

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

Here, Excel automatically assumes to shift left on an entire column.
Also, because Linking mode is compromised with the delete, it will
automatically remove itself from CutCopyMode


Hope this helps in some way... :>~
Dana DeLouis


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 ~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Click to expand...
 
A

alishehzad

Dear Dana,

THANKS A LOT for your help.

You have beautifully explained by pasting a part of original
cumbersome code with you own short and smart code !!

You are right abt the fact that these changes dont affect the speed
much BUT ... I have incorporated all these changes and my code has now
become Shorter, Concise and more Legible :)

And most of all... I'm learning what is the proper way to do a task.
Im new at Macros. I havent even studied any guide or a book. I started
by recording and editing macros about 6 weeks ago. So my programming
is very CRUDE (though it still serves my purpose).

Im thankful to all of you for helping me learn good excel programming
practices.

Please do come back and explain any more of the things you think might
help me. There is no hurry. Just when you have time and feel at
ease...

Thanks a lot once more ...

Regards,
 
A

alishehzad

Thanks people,

Here is my improved code... with the suggested changes incroporated.


-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~ CODE -~-~-~-~-~-~-~-~-~-~-~-~-~-~-
~-~-~-~-~-~-~-~-~-~-~
-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
~-~-~-~-~-~-~-~-~-~-~-~

Sub Aa_Huawei()
'
'
'
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



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

' Variables For Date Loop
Dim Start_Date As Date
Dim End_Date As Date
Const Huawei_FileName As String = "Huawei_cell_#.csv"

Dim Days As Integer
Dim Days_Ctr As Integer




Start_Date = InputBox("Please Enter the Starting date: ", "Start
Date", "5/13/2007")
End_Date = InputBox("Please Enter the End date: ", "End Date",
"5/15/2007")

If End_Date < Start_Date Then
Response = MsgBox("ERROR! End Date smaller than Start Date. Please
Try Again...", vbOKOnly, "Error Msg")
Exit Sub

End If



Days = End_Date - Start_Date + 1

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:="E:\Work\Activities\Stats New
\Factory_Stats\Huawei_Stats_Cell_IDs.xls"

For Days_Ctr = 0 To Days - 1

File_Name = Replace(Huawei_FileName, "#", Format(Start_Date +
Days_Ctr, "ddmmyyyy"))

Application.ScreenUpdating = False

Workbooks.Open FileName:="E:\Work\Activities\Stats New
\Factory_Stats\" & File_Name

GoSub Select_My_Columns

GoSub Get_Site_ID

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

Workbooks.Open FileName:="E:\Work\Activities\Stats New
\Factory_Stats\Factory.xls"

Workbooks(File_Name).Sheets(1).Range("A2:H" & LastRow&).Copy
Workbooks("Factory.xls").Sheets(1).Range("A2")

Windows(File_Name).Close SaveChanges:=False

LastRow =
Workbooks("Factory.xls").Sheets(1).Cells(Rows.Count,
"H").End(xlUp).Row

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


GoSub Remove_Hash

GoSub Del_Zero_Sites

Cut_Sides (18)

GoSub First_Row_Char

Application.ScreenUpdating = True

My_Date = Format([D3], "yyyy_mm_dd")


ChDir "E:\Work\Activities\Stats New\Factory_Stats"
ActiveWorkbook.SaveAs FileName:= _
"E:\Work\Activities\Stats New\Factory_Stats\" & My_Date &
"_Huawei.xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False _
, CreateBackup:=False

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


Next Days_Ctr

Windows("Huawei_Stats_Cell_IDs.xls").Close

Response = MsgBox(" Success..!" & vbCr & vbCr & " " & Days &
" files have been created.", 0, "Ali Shehzad, RF Planning ")


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).Cut
Columns("A:A").Insert Shift:=xlToRight

Next i

Cut_Sides (7)

Range("A2").Select

Return

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

Get_Site_ID:

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

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

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

With Sheets(1).Range("B2:C2")
.AutoFill Destination:=Range("B2:C" & LastRow&)
Range("B2:C" & LastRow&).Copy
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
End With

GoSub Check_New_Cells


Columns("A:A").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

' 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).EntireRow.Cut
Rows(2).Insert Shift:=xlDown

Range("A2").Activate

Return


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

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

Return

' Check New Cells
********************************************************************
'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).AutoFilter

Cut_Sides (11)

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).FormulaR1C1 = "=SUBTOTAL(9,RC[-4]:RC[-1])"


LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("J2:J" & LastRow&).FillDown

Rows(1).AutoFilter ' Autofilter OFF

Columns(10).Copy
Columns(10).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("A2").Select

Rows(1).AutoFilter 'Autofilter ON


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).FormulaR1C1 =
"=IF(COUNTIF(R2C1:RC[-10],RC[-10])=1,RC[-10],"""")"
Range("K2:K" & LastRow - 1&).FillDown


GoSub Get_Record_Count

If Filtered_Record_Count = 0 Then

Rows(1).AutoFilter ' REMOVE FILTERS ... I.E. SHOW ALL
Cut_Sides (9)

Else
Columns(11).EntireColumn.AutoFit

Windows("Huawei_Stats_Cell_IDs.xls").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
' THE GENERIC ONE IS IN BTS_PROGRESS_CHECK

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

With Selection
.Interior.ColorIndex = 40
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With

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

Public Sub Cut_Sides(LastColumn)

If LastColumn = 0 Then LastColumn = Cells(1,
255).End(xlToLeft).Column + 1

Range(Columns(LastColumn + 1), Columns(LastColumn +
1).End(xlToRight)).EntireColumn.Delete

LastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
Rows("65536:" & LastRow).Delete Shift:=xlUp
End Sub

-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
~-~-~-~-~-~-~-~-~-~-~-~
-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
~-~-~-~-~-~-~-~-~-~-~-~
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Transpose data into a single cloumn 6
Paste failing after cut 8
Macro to fill to next field with data 4
Subtotal Formatting 2
variable number of rows. 3
VB Printing problem 0
Select contiguous cells by ActiveCell.Interior.ColorIndex and applyborders 13
"Run-time error '1004' 5

Top