Un jour, j'ai reçu un e-mail de diffusion de Jan à la PMA. Elle transmettait une excellente idée de Gary Gagliardi de Clearbridge Publishing. Gary a mentionné que certains moteurs de recherche attribuent un classement de page à une page en fonction du nombre d'autres sites qui renvoient à la page. Il suggérait que si les 4000 membres de la PMA se liaient aux 4000 autres membres de la PMA, cela augmenterait tous nos classements. Jan a pensé que c'était une excellente idée et a déclaré que toutes les adresses Web des membres de PMA sont répertoriées sur le site Web actuel de PMA dans la zone des membres.
Personnellement, je pense que la théorie du «nombre de liens» est un peu un mythe, mais j'étais prêt à l'essayer pour aider.
J'ai donc visité la zone des membres de la PMA, où j'ai rapidement appris qu'il n'y avait pas une seule liste de membres, mais en fait 27 listes de membres.
En cliquant sur la page «A», j'ai vu que c'était encore pire. Chaque lien sur cette page ne mène pas au site Web du membre. Chaque lien ici mène à une page individuelle sur PMA-online avec le site Web du membre.
Cela signifierait que je devrais visiter des milliers de pages Web afin de compiler la liste des membres. Ce serait clairement une proposition insensée.
Heureusement, je suis le co-auteur de VBA & Macros pour Microsoft Excel. Je me suis demandé si je pouvais personnaliser le code du livre pour résoudre le problème de l'extraction des URL des membres à partir de milliers de pages liées.
Le chapitre 14 du livre traite de l'utilisation d'Excel pour lire et écrire sur le Web. À la page 335, j'ai trouvé du code qui pouvait créer une requête Web à la volée.
La première étape a été de voir si je pouvais personnaliser le code dans le livre pour pouvoir produire 27 requêtes Web - une pour chacune des lettres de l'alphabet et le numéro 1. Cela me donnerait plusieurs listes de tous les liens sur le 26 listes de pages alphabétiques.
Chaque page a une URL similaire à http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. J'ai pris le code de la page 335 et l'ai personnalisé un peu pour faire 27 requêtes Web.
Sub CreateNewQuery() ' Page 335 Dim WSD As Worksheet Dim WSW As Worksheet Dim QT As QueryTable For m = 1 To 27 Select Case m Case 27 MyStr = "1" Case Else MyStr = Chr(64 + m) End Select MyName = "Query" & m ConnectString = "URL;http://www.pma-online.org/scripts/showmemlist.cfm?letter=" & MyStr ThisWorkbook.Worksheets.Add ActiveSheet.Name = m ' On the Workspace worksheet, clear all existing query tables For Each QT In ActiveSheet.QueryTables QT.Delete Next QT ' Define a new Web Query Set QT = ActiveSheet.QueryTables.Add(Connection:=ConnectString, Destination:=Range("A1")) With QT .Name = MyName .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .WebSelectionType = xlSpecifiedTables .WebFormatting = xlWebFormattingAll .WebTables = "7" .WebPreFormattedTextToColumns = True .WebConsecutiveDelimitersAsOne = True .WebSingleBlockTextImport = False .WebDisableDateRecognition = False .WebDisableRedirections = False End With ' Refresh the Query QT.Refresh BackgroundQuery:=True Next m End SubQuatre éléments ont été personnalisés dans le code ci-dessus.
- Tout d'abord, j'ai dû créer l'URL correcte. Cela a été réalisé en ajoutant la lettre appropriée à la fin de la chaîne URL.
- Deuxièmement, j'ai modifié le code pour exécuter chaque requête sur une nouvelle feuille de calcul dans le classeur.
- Troisièmement, le code du livre récupérait la 20e table de la page Web. En enregistrant une macro tirant dans la table de PMA, j'ai appris que j'avais besoin de la 7ème table sur la page Web.
- Quatrièmement, après avoir exécuté la macro, j'ai été déçu de voir que j'obtenais les noms des éditeurs, mais pas les hyperliens. Le code du livre spécifié .WebFormatting: = xlFormattingNone. En utilisant l'aide de VBA, j'ai pensé que si je changeais en .WebFormatting: = xlFormattingAll, j'obtiendrais les hyperliens réels.
Après avoir exécuté cette première macro, j'avais 27 feuilles de calcul, chacune avec une série d'hyperliens qui ressemblaient à ceci:
L'étape suivante consistait à extraire l'adresse hypertexte de chaque lien hypertexte sur les 27 feuilles de calcul. Ce n'est pas dans le livre, mais il existe un objet hyperlien dans Excel. L'objet a une propriété .Address qui renverrait la page Web dans PMA-Online avec l'URL de cet éditeur.
Sub GetEmAll() NextRow = 1 Dim WSD As Worksheet Dim WS As Worksheet Set WSD = Worksheets("Sheet1") For Each WS In ActiveWorkbook.Worksheets If Not WS.Name = "Sheet1" Then For Each cll In WS.UsedRange.Cells For Each hl In cll.Hyperlinks WSD.Cells(NextRow, 1).Value = hl.Address NextRow = NextRow + 1 Next hl Next cll End If Next WS End SubAprès avoir exécuté cette macro, j'ai finalement appris qu'il y avait 4119 pages Web individuelles sur le site PMA. Je suis heureux de ne pas avoir essayé de visiter chaque site individuellement à la fois!
Mon prochain objectif était de créer une requête Web pour visiter chacune des 4119 pages Web individuelles. J'ai enregistré une macro renvoyant l'une des pages de l'éditeur individuel pour apprendre que je voulais la table n ° 5 de chaque page. Je pouvais voir que le nom de l'éditeur était renvoyé comme cinquième ligne du tableau. Dans la plupart des cas, le site Web a été renvoyé à la 13e ligne. Cependant, j'ai appris que dans certains cas, si l'adresse postale était de 3 lignes au lieu de 2, l'URL du site Web était en fait sur la ligne 14. S'ils avaient 3 téléphones au lieu de 2, le site Web était poussé vers le bas d'une autre ligne. La macro devrait être suffisamment flexible pour rechercher peut-être de la ligne 13 à 18 afin de trouver la cellule qui a commencé WWW :.
Il y avait un autre dilemme. Le code du livre permet à la requête Web de s'actualiser en arrière-plan. Dans la plupart des cas, je regarderais la requête se terminer une fois la macro terminée. Ma première pensée était d'autoriser 40 lignes pour chaque éditeur et de créer les 4100 requêtes sur chaque page. Cela aurait nécessité 80 000 lignes de feuille de calcul et beaucoup de mémoire. Dans Excel 2002, j'ai expérimenté la modification de BackgroundRefresh sur False. VBA a bien réussi à extraire les informations dans la feuille de calcul avant que la macro ne se poursuive. Cela permettait de créer la requête, d'actualiser la requête, d'enregistrer les valeurs dans une base de données, puis de supprimer la requête. En utilisant cette méthode, il n'y avait jamais plus d'une requête à la fois sur la feuille de calcul.
Sub AllQuery() Dim WS As Worksheet Dim WD As Worksheet Set WD = Worksheets("database") Set WS = Worksheets("Sheet1") Dim QT As QueryTable WS.Activate OutCol = 8 OutRow = 1 FinalRow = WS.Cells(65536, 1).End(xlUp).Row For i = 2 To FinalRow ConnectString = "URL;" & WD.Cells(i, 12).Value Application.StatusBar = i ' Save after every 500 queries If i Mod 500 = 0 Then ThisWorkbook.Save End If MyName = "Query" & i ' Define a new Web Query Set QT = ActiveSheet.QueryTables.Add(Connection:=ConnectString, Destination:=WS.Cells(OutRow, OutCol)) With QT .Name = MyName .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = False .RefreshStyle = xlOverwriteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .WebSelectionType = xlSpecifiedTables .WebFormatting = xlWebFormattingNone .WebTables = "5" .WebPreFormattedTextToColumns = True .WebConsecutiveDelimitersAsOne = True .WebSingleBlockTextImport = False .WebDisableDateRecognition = False .WebDisableRedirections = False End With ' Refresh the Query QT.Refresh BackgroundQuery:=False ' Change from a live query to values WS.Cells(OutRow, OutCol).Resize(40, 2).Value = WS.Cells(OutRow, OutCol).Resize(40, 2).Value For Each QT In WS.QueryTables QT.Delete Next QT ' Copy to Database WD.Cells(i, 1).Value = WS.Cells(5, 8).Value For j = 13 To 20 CheckIt = WS.Cells(j, 8).Value If Left(CheckIt, 3) = "WWW" Then WD.Cells(i, 8).Value = CheckIt End If Next j Next i End SubCette requête a pris plus d'une heure à s'exécuter. Après tout, il faisait le travail de visiter plus de 4000 pages Web. Il a fonctionné sans accroc et n'a pas fait planter l'ordinateur ou Excel.
J'ai ensuite eu une belle base de données dans Excel avec le nom de l'éditeur dans la colonne A et le site Web dans la colonne B. Après avoir trié par site Web dans la colonne B, j'ai constaté que plus de 1000 éditeurs ne listaient pas de site Web. Leur entrée dans la colonne B était une URL vide. J'ai trié et supprimé ces lignes.
En outre, les sites Web répertoriés dans la colonne B avaient "WWW:" avant chaque URL. J'ai utilisé un Edit> Replace pour changer chaque occurrence de WWW: (avec un espace après) en rien. J'avais une belle liste de 2339 éditeurs sur une feuille de calcul.
La dernière étape consistait à rédiger un fichier texte qui pouvait être copié et collé sur le site Web de n'importe quel membre. La macro suivante (adaptée du code de la page 345) a bien géré cette tâche.
Sub WriteHTML() On Error Resume Next Kill "C:PMALinks.txt" On Error GoTo 0 Open "C:PMALinks.txt" For Output As #1 Print #1, "Visit the websites of our fellow PMA members:
" For i = 2 To 2340 MyStr = "
- " & Cells(i, 1).Value & "" Print #1, MyStr Next i Print #1, "
" Close #1 End SubLe résultat était un fichier texte avec le nom et l'URL de plus de 2000 éditeurs.
Tout le code ci-dessus a été adapté du livre. Quand j'ai commencé, je faisais en quelque sorte un programme ponctuel que je n'envisageais pas d'exécuter régulièrement. Cependant, je peux maintenant visualiser le site Web de PMA tous les mois environ pour obtenir les listes mises à jour des URL.
Il serait possible de mettre toutes les étapes ci-dessus dans une seule macro.
Sub DoEverything() Dim WSW As Worksheet Dim WST As Worksheet Set WSW = Worksheets("Workspace") Set WST = Worksheets("Template") On Error Resume Next Kill "C:AutoLinks.txt" On Error GoTo 0 Open "C:PMALinks.txt" For Output As #1 Print #1, "Visit the websites of our fellow PMA members:
" For m = 1 To 27 Select Case m Case 27 MyStr = "1" Case Else MyStr = Chr(64 + m) End Select MyName = "Query" & m ConnectString = "URL;http://www.pma-online.org/scripts/showmemlist.cfm?letter=" & MyStr ' On the Workspace worksheet, clear all existing query tables For Each QT In WSW.QueryTables QT.Delete Next QT ' Define a new Web Query Set QT = WSW.QueryTables.Add(Connection:=ConnectString, Destination:=WSW.Range("A1")) With QT .Name = MyName .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .WebSelectionType = xlSpecifiedTables .WebFormatting = xlWebFormattingAll .WebTables = "7" .WebPreFormattedTextToColumns = True .WebConsecutiveDelimitersAsOne = True .WebSingleBlockTextImport = False .WebDisableDateRecognition = False .WebDisableRedirections = False End With ' Refresh the Query QT.Refresh BackgroundQuery:=False ' Next, loop through all of the hyperlinks in the resulting page For Each cll In WSW.UsedRange.Cells For Each hl In cll.Hyperlinks MyURL = hl.Address ' Build a web query on WST ConnectString = "URL;" & MyURL MyName = "Query" & NextRow ' Define a new Web Query Set QT = WST.QueryTables.Add(Connection:=ConnectString, Destination:=WST.Cells(1, 1)) With QT .Name = MyName .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = False .RefreshStyle = xlOverwriteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .WebSelectionType = xlSpecifiedTables .WebFormatting = xlWebFormattingNone .WebTables = "5" .WebPreFormattedTextToColumns = True .WebConsecutiveDelimitersAsOne = True .WebSingleBlockTextImport = False .WebDisableDateRecognition = False .WebDisableRedirections = False End With ' Refresh the Query QT.Refresh BackgroundQuery:=False ' Change from a live query to values WST.Cells(1, 1).Resize(40, 2).Value = WST.Cells(1, 1).Resize(40, 2).Value For Each QT In WS.QueryTables QT.Delete Next QT ' Find URL ThisPub = WS.Cells(5, 8).Value ThisURL = "WWW: http://" For j = 13 To 20 CheckIt = WS.Cells(j, 8).Value If Left(CheckIt, 3) = "WWW" Then ThisURL = CheckIt End If Next j If Not ThisURL = "WWW: http://" Then ' write a record to the .txt file MyStr = "
- " & ThisPub & "" Print #1, MyStr End If Next hl Next cll Next m Print #1, "
" Close #1 End SubExcel et VBA ont fourni une alternative rapide à la visite individuelle de milliers de pages Web. En théorie, la PMA aurait dû être en mesure d'interroger sa base de données et de fournir ces informations beaucoup plus rapidement qu'en utilisant cette méthode. Cependant, vous avez parfois affaire à quelqu'un qui ne coopère pas ou ne sait peut-être pas comment extraire des données d'une base de données que quelqu'un d'autre a écrite pour lui. Dans ce cas, un peu de code macro VBA a résolu notre problème.
