Link to home
Start Free TrialLog in
Avatar of Shums Faruk
Shums FarukFlag for India

asked on

Lookup Worksheet Name and Update every sheet automatically on daily basis

Hello Experts,

I have a workbook, in which I have to update web based data manually on daily basis.
I have couple of VBA which reduces my work, but I am sure there is a way to get this thing done fully automated.

First below vba goes to the last blank row and insert row, fill down formula & format and add today's date in column A in every sheet.

Sub InsertRow()
    Dim ws As Worksheet
    Dim n As Long, k As Long
    
    For Each ws In Worksheets
    SpeedOn
    ws.Select
    Range("A1").End(xlDown).Offset(1).Select
    ActiveWindow.SmallScroll Down:=1
    Range(ActiveCell, ActiveCell.Offset(Val(1) - 1, 0)).EntireRow.Insert
    k = ActiveCell.Offset(-1, 0).Row
    n = Cells(k, 82).End(xlToLeft).Column
    Range(Cells(k, 82), Cells(k + Val(1), n)).FillDown
    With ActiveCell
    .Value = Format(Date, "dd-mmm-yy")
    .Offset(0, 1).Value = ""
    End With
    Next ws
SpeedOff
Worksheets(1).Activate
Exit Sub
CalcBack:
Application.Calculation = glb_origCalculationMode
End Sub

Open in new window


Secondly below VBA extracts web based data in another workbook:
Sub BSEIndicesWatch()
    Dim wb As Workbook
    Dim wsSource As Worksheet
    Dim qt As QueryTable
    SpeedOn
    Set wb = ThisWorkbook
    Set wsSource = wb.Worksheets("BSEIndexWatch")
    Set qt = wsSource.QueryTables.Add(Connection:= _
        "URL;http://www.bseindia.com/indices/indexwatch.aspx?expandable=0", Destination:=wsSource.Range("$A$1" _
        ))
        
    With Worksheets("BSEIndexWatch")
        .Range(.Range("A1"), .UsedRange. _
        SpecialCells(xlCellTypeLastCell)).ClearContents
    End With
    
    With qt
        .Name = "indexwatch"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    SpeedOff
End Sub

Open in new window



From the extraction, I am copying and paste special values in every sheet manually.

I would like to consolidate extraction vba in the same workbook, from where it would be easy to enter such function "=VLOOKUP(REPLACE(CELL("filename",$A$1),1,FIND("]",CELL("filename",$A$1)),""),BSEIndexWatch!$A:$E,2,FALSE)". But if I am doing so, InsertRow vba doesn't work as it will insert row in all the worksheet, I would like to run that vba without disturbing "BSEIndexWatch" sheet. Then it must enter above formula to the last blank row in column B for every sheet.

It's quiet simple for you guys, but its complicated for me.

Please advice......
Avatar of Shums Faruk
Shums Faruk
Flag of India image

ASKER

Ok guys,

I edited as per below and its working perfectly fine:
Sub InsertRow()
    Dim ws As Worksheet
    Dim n As Long, k As Long
    SpeedOn
    For Each ws In Worksheets
    If ws.Name <> "BSEIndexWatch" Then
    ws.Select
    Range("A1").End(xlDown).Offset(1).Select
    ActiveWindow.SmallScroll Down:=1
    Range(ActiveCell, ActiveCell.Offset(Val(1) - 1, 0)).EntireRow.Insert
    k = ActiveCell.Offset(-1, 0).Row
    n = Cells(k, 82).End(xlToLeft).Column
    Range(Cells(k, 82), Cells(k + Val(1), n)).FillDown
    With ActiveCell
    .Value = Format(Date, "dd-mmm-yy")
    .Offset(0, 1).Formula = "=VLOOKUP(REPLACE(CELL(""filename"",R1C1),1,FIND(""]"",CELL(""filename"",R1C1)),""""),BSEIndexWatch!C1:C5,2,FALSE)"
    .Offset(0, 2).Formula = "=VLOOKUP(REPLACE(CELL(""filename"",R1C1),1,FIND(""]"",CELL(""filename"",R1C1)),""""),BSEIndexWatch!C1:C5,3,FALSE)"
    .Offset(0, 3).Formula = "=VLOOKUP(REPLACE(CELL(""filename"",R1C1),1,FIND(""]"",CELL(""filename"",R1C1)),""""),BSEIndexWatch!C1:C5,4,FALSE)"
    .Offset(0, 4).Formula = "=VLOOKUP(REPLACE(CELL(""filename"",R1C1),1,FIND(""]"",CELL(""filename"",R1C1)),""""),BSEIndexWatch!C1:C5,5,FALSE)"
    .Offset(0, 1).Copy
    .Offset(0, 1).PasteSpecial xlPasteValues
    .Offset(0, 2).Copy
    .Offset(0, 2).PasteSpecial xlPasteValues
    .Offset(0, 3).Copy
    .Offset(0, 3).PasteSpecial xlPasteValues
    .Offset(0, 4).Copy
    .Offset(0, 4).PasteSpecial xlPasteValues
    Range("A1").End(xlDown).Select
    End With
    End If
    Next ws
SpeedOff
Worksheets(2).Activate
Exit Sub
CalcBack:
Application.Calculation = glb_origCalculationMode
End Sub

Open in new window


Then I added separate vba for consolidation:
Sub UpdateBseIndices()

    SpeedOn
    Call BSEIndicesWatch
    Call InsertRow
    SpeedOff
End Sub

Open in new window


If you still have better idea please advice, I will leave this thread open.
Hi again,

I would like to run above vba as per below vba to open that file, run vba, close and save. I understand above vba will not work as I have specified active cell. Please advice better option....
Sub UpdateIndices()
Workbooks.Open "C:\BSE_Indices.xlsm"
Application.Run "C:\BSE_Indices.xlsm!UpdateBseIndices"
Workbooks("BSE_Indices.xlsm").Close savechanges:=True
End Sub

Open in new window

when you open the workbook, it does become the activeworkbook and thus activesheet as well.

to understand what you are trying to do....

1. your have a master workbook that has the UpdateIndices macro within
2. you currently have the pdateBseIndices code withing the indices workbook.

why not move the macro to the master workbook ?  And then reference the correct workbook in the UpdateBseIndices macro rather than ActiveWorkbook / ActiveSheet.

Sub UpdateIndices()

    dim wbIndices as WorkBook
    set wbIndices = Workbooks.Open ("C:\BSE_Indices.xlsm")
    UpdateBSEIncices(wbIndices)

   wbIndices.Close savechanges:=true

End sub
ASKER CERTIFIED SOLUTION
Avatar of Shums Faruk
Shums Faruk
Flag of India image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Working Perfectly...................