Hello everyone,

I'm new at this so please bear with me.

I have a list of Titles & urls that go to Staff directories and I have been using web query to import the data from the directory to a new page where the directory information is displayed in the table view.

I have a lot of these URLs so it would be great if I could set up a Macro that will run through my list, "Get Data" from the URL (which is in Column C), create a new sheet and import it there & then rename the connection after the title in column A. And then doing the same with the next row and so on.

I tried recording a macro and got this code below which does some of it but doesn't finish the job.

I'm new to VBA but I'm very experienced with excel so I have a general idea of what needs to happen. I Just don't know how to get it to.

For privacy, instead of including the url/title I am using in my sheet, I wrote Website URL & Title where they would be located.

I would greatly appreciate any help!



Sub ImportDirectory()
'
' ImportDirectory Macro
'
' Keyboard Shortcut: Ctrl+d
'
    '   Copy Url in Column C
    Selection.Copy
    
    '   Paste URL in "Get Data" Address bar | Need to get the Web.Contents to reference the cell
    ActiveWorkbook.Queries.Add Name:= _
        "Staff Directory Members By Category/Department", Formula:= _
        "let" & Chr(13) & "" & Chr(10) & "    Source = Web.Page(Web.Contents(""Website Url""))," & Chr(13) & "" & Chr(10) & "    Data0 = Source{0}[Data]," & Chr(13) & "" & Chr(10) & "    #""Changed Type"" = Table.TransformColumnTypes(Data0,{{""Name"", type text}, {""Title"", type text}, {""Phone"", type text}, {""Email Address"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Changed Type"""
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array( _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""Staff Directory Members By Category/Department"";Extended Prop" _
        , "erties="""""), Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array( _
        "SELECT * FROM [Staff Directory Members By Category/Department]")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = "Staff_Directory_Members_By_Category_Department"
        .Refresh BackgroundQuery:=False
    End With

'   Copy Cell in Column A
    Sheets("Sheet1").Select
    Range("A14").Select
    Application.CutCopyMode = False
    Selection.Copy
    
'   Rename Connection & Paste In Rename
    ActiveSheet.ListObjects("Staff_Directory_Members_By_Category_Department").Name _
        = "Title"
End Sub