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.
[VBA]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
[/VBA]
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......
Reply With Quote
