PDA

View Full Version : Need VBA Code rectification



Shums
03-29-2012, 10:40 AM
Hi All,

I have below code which extracts last row data of all worksheet from closed workbooks from a specific folder, then format as needed.
Option Explicit

Public glb_origCalculationMode As Integer

Sub SpeedOn(Optional StatusBarMsg As String = "Running macro...")
glb_origCalculationMode = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Cursor = xlWait
.StatusBar = StatusBarMsg
.EnableCancelKey = xlErrorHandler
End With
End Sub

Sub SpeedOff()
With Application
.Calculation = glb_origCalculationMode
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.CalculateBeforeSave = True
.Cursor = xlDefault
.StatusBar = False
.EnableCancelKey = xlInterrupt
End With
End Sub
Sub GetMyData()
Dim pFolder As String, fileList As Variant, f As Variant
Dim cr As Long, cs As Worksheet, ws As Worksheet
Dim slaveWB As Workbook, slaveCols() As Variant, masterCols() As Variant
Dim i As Integer, lr As Long

On Error GoTo TheEnd
SpeedOn

'Set the parent folder of slave workbooks to process.
pFolder = "C:\Documents and Settings\Shums\Desktop\BSE\Desktop\Updation" & "\" '<-------- Change as needed.

' Set the column names for the slave and master workbooks with 1-1 match.
' Both arrays must have the same number of elements.
masterCols() = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N")
slaveCols() = Array("B", "C", "D", "E", "F", "G", "H", "U", "AJ", "AW", "BE", "BS")

'Add a new sheet and name it with today's date:
Set cs = Worksheets.Add(After:=ActiveSheet, Count:=1)
cs.Name = Format(Date, "dd-MMM-yy")

' Add header:
Range("A1").Value = "Sr. No."
Range("B1").Value = "Scrip Code"
Range("C1").Value = "Open"
Range("D1").Value = "High"
Range("E1").Value = "Low"
Range("F1").Value = "Close"
Range("G1").Value = "Volume"
Range("H1").Value = "Changes Value"
Range("I1").Value = "Changes %"
Range("J1").Value = "EMA13"
Range("K1").Value = "RSI"
Range("L1").Value = "Remarks"
Range("M1").Value = "SMA 200"
Range("N1").Value = "Ultimate Oscillator"
Range("O1").Value = "List as Per RSI"
Range("P1").Value = "RSI vs Close %"
Range("Q1").Value = "List as Per %"
Range("R1").Value = "Final Remarks"
Range("A1:R1").HorizontalAlignment = xlCenter
Range("A1:R1").VerticalAlignment = xlCenter
Range("A1:R1").WrapText = True
Range("A1:R1").Font.Bold = True
Range("A1:R1").Interior.ColorIndex = 6
Range("A1:R1").Borders.LineStyle = xlDouble
Rows("1:1").RowHeight = 28.5
Range("A:A").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("N:N").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("K2:K340").Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLessEqual, _
Formula1:="20"
With Selection.FormatConditions(1).Font
.Bold = True
.Italic = False
.ColorIndex = 19
End With
Selection.FormatConditions(1).Interior.ColorIndex = 51
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreaterEqual _
, Formula1:="80"
With Selection.FormatConditions(2).Font
.Bold = True
.Italic = False
.ColorIndex = 36
End With
Selection.FormatConditions(2).Interior.ColorIndex = 3
Range("N2:N340").Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLessEqual, _
Formula1:="20"
With Selection.FormatConditions(1).Font
.Bold = True
.Italic = False
.ColorIndex = 19
End With
Selection.FormatConditions(1).Interior.ColorIndex = 51
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreaterEqual _
, Formula1:="80"
With Selection.FormatConditions(2).Font
.Bold = True
.Italic = False
.ColorIndex = 36
End With
Selection.FormatConditions(2).Interior.ColorIndex = 3
Range("L2:L340").Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""BuyingPoint"""
With Selection.FormatConditions(1).Font
.Bold = True
.Italic = False
.ColorIndex = 19
End With
Selection.FormatConditions(1).Interior.ColorIndex = 51
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""SellingPoint"""
With Selection.FormatConditions(2).Font
.Bold = True
.Italic = False
.ColorIndex = 19
End With
Range("O2").Select
ActiveCell.FormulaR1C1 = _
"=IF(OR(AND(RC[-4]<22),AND(RC[-4]>78)),""Watch Out For Tomorrow"","""")"
Range("O2").Select
Selection.Copy
Range("N2").Select
Selection.End(xlDown).Select
Range("O340").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.End(xlUp).Select
Range("P2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=(RC[-10]-RC[-3])/RC[-3]"
Range("P2").Select
Selection.Copy
Range("N2").Select
Selection.End(xlDown).Select
Range("P340").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.End(xlUp).Select
Columns("P:P").Select
Application.CutCopyMode = False
Selection.NumberFormat = "#,##0.00%_);[Red](#,##0.00%)"
Range("Q2").Select
ActiveWindow.SmallScroll Down:=-12
ActiveCell.FormulaR1C1 = _
"=IF((RC[-11]-RC[-4])/RC[-4]<=2%,IF((RC[-11]-RC[-4])/RC[-4]>=-3%,""Watch Out For Tomorrow"",""""))"
Range("Q2").Select
Selection.Copy
Range("P2").Select
Selection.End(xlDown).Select
Range("Q340").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.End(xlUp).Select
Range("R2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=IF(RC[-3]=""Watch Out For Tomorrow"",RC[-3],IF(RC[-1]=""Watch Out For Tomorrow"",RC[-1],""""))"
Range("R2").Select
Selection.Copy
Range("Q2").Select
Selection.End(xlDown).Select
Range("R340").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.End(xlUp).Select
Range("Q2").Select
ActiveCell.FormulaR1C1 = _
"=IF((RC[-11]-RC[-4])/RC[-4]<=3%,IF((RC[-11]-RC[-4])/RC[-4]>=-3%,""Watch Out For Tomorrow"",""""))"
Range("Q2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.FillDown
Selection.End(xlUp).Select
Cells.Select
Cells.EntireColumn.AutoFit
Range("O1").Select
Columns("O:O").ColumnWidth = 8.5
Columns("P:P").ColumnWidth = 8.5
Columns("M:M").ColumnWidth = 8.5
Columns("N:N").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("N2").Select
ActiveWindow.SmallScroll Down:=-18
Columns("K:K").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("O:O").Select
Selection.EntireColumn.Hidden = True
Columns("Q:Q").Select
Selection.EntireColumn.Hidden = True
Range("R1").Select
Columns("R:R").Select
Selection.AutoFilter
Range("R1").Select
Selection.AutoFilter Field:=1, Criteria1:="Watch Out For Tomorrow"
Range("A2").Select
ActiveWindow.FreezePanes = True

' Open each workbook except thisworkbook and get the data.
cr = 1
fileList = GetFileList(pFolder & "*.xl*")
For Each f In fileList
If ThisWorkbook.Name = f Then GoTo Nextf

'Do your thing from here to Nextf.
Set slaveWB = Workbooks.Open(pFolder & f)

'Add the data from slave to master.
For Each ws In slaveWB.Worksheets
cr = cr + 1
cs.Range("A" & cr).Value = cr - 1
cs.Range("B" & cr).Value = ws.Name
lr = ws.Range("A1").End(xlDown).Row
For i = LBound(slaveCols) To UBound(slaveCols)
cs.Range(masterCols(i) & cr).Value = ws.Range(slaveCols(i) & lr).Value
cs.Range(masterCols(i) & cr).NumberFormat = ws.Range(slaveCols(i) & lr).NumberFormat
Next i
Next ws
slaveWB.Close False
Nextf:
Next f

'Autofit the columns.
cs.UsedRange.Columns.AutoFit

TheEnd:
SpeedOff
End Sub

Function GetFileList(FileSpec As String) As Variant
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False

Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String

On Error GoTo NoFilesFound

FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound

' Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function

' Error handler
NoFilesFound:
GetFileList = False
End Function


My problem are below:

1. It doesn't format all the headers in Rows("1:1") as required. I want it to format as
Range("A1:R1").HorizontalAlignment = xlCenter
Range("A1:R1").VerticalAlignment = xlCenter
Range("A1:R1").WrapText = True
Range("A1:R1").Font.Bold = True
Range("A1:R1").Interior.ColorIndex = 6
Range("A1:R1").Borders.LineStyle = xlDouble

2. Secondly I am specifying range as Range("K2:K340").Select for conditional formatting, could you please modify it to format Column K only for cells containing data, If I specify Range("K:K"), it does conditional formatting to whole column. Same for column N & L

3. I inserted formula in cell O2, I want to fill this formula till the last row of the data instead I refer it to go last row from column N. Same I did for column P & Q.

4. Now the important part; I would like to like to have AutoFilter only on Column R and filter as per required, but it doesn't do anything.

5. After running complete code, application must change to .Calculation = glb_origCalculationMode, which still stays at manual.

Please help......

Bob Phillips
03-29-2012, 10:46 AM
1. - precede all of the Range by cs. perhaps?

Shums
03-29-2012, 01:31 PM
I didn't get it right. Please brief...

Bob Phillips
03-29-2012, 02:17 PM
I not sure I am understanding what you mean.

Shums
03-30-2012, 08:07 AM
Hi All,

I have above code which extracts last row data of all worksheet from closed workbooks from a specific folder, then format as needed.

Can Anyone help me in formating resulted data & Auto-Filter only column R as per criteria?