Μια μέρα, έλαβα ένα e-mail μετάδοσης από τον Jan στο PMA. Διαβίβασε μια υπέροχη ιδέα από τον Gary Gagliardi του Clearbridge Publishing. Ο Gary ανέφερε ότι ορισμένες μηχανές αναζήτησης εκχωρούν μια κατάταξη σελίδας σε μια σελίδα με βάση τον αριθμό άλλων ιστότοπων που συνδέονται με τη σελίδα. Υποστήριξε ότι εάν και τα 4000 μέλη του PMA θα συνδεθούν με τα 4000 άλλα μέλη του PMA, θα ενισχύσει όλες τις βαθμολογίες μας. Ο Jan πίστευε ότι αυτή ήταν μια υπέροχη ιδέα και είπε ότι όλες οι διευθύνσεις ιστού των μελών του PMA παρατίθενται στον τρέχοντα ιστότοπο PMA στην περιοχή μελών.
Προσωπικά, πιστεύω ότι η θεωρία "αριθμός συνδέσμων" είναι λίγο μύθος, αλλά ήμουν πρόθυμη να το δοκιμάσω για να βοηθήσω.
Έτσι, επισκέφτηκα την περιοχή μελών του PMA, όπου γρήγορα έμαθα ότι δεν υπήρχε ούτε μία λίστα μελών, αλλά στην πραγματικότητα 27 λίστες μελών.
Καθώς έκανα κλικ στη σελίδα "Α", είδα ότι ήταν ακόμη χειρότερο. Κάθε σύνδεσμος σε αυτήν τη σελίδα δεν οδηγεί στον ιστότοπο του μέλους. Κάθε σύνδεσμος εδώ οδηγεί σε μια μεμονωμένη σελίδα στο PMA-online με τον ιστότοπο του μέλους.
Αυτό θα σήμαινε ότι θα έπρεπε να επισκεφτώ χιλιάδες ιστοσελίδες για να καταρτίσω τη λίστα των μελών. Αυτό θα ήταν σαφώς μια τρελή πρόταση.
Ευτυχώς, είμαι ο συν-συγγραφέας των VBA & Macros για το Microsoft Excel. Αναρωτήθηκα αν θα μπορούσα να προσαρμόσω τον κώδικα από το βιβλίο για να λύσω το πρόβλημα της εξαγωγής διευθύνσεων URL μελών από χιλιάδες συνδεδεμένες σελίδες.
Το κεφάλαιο 14 του βιβλίου αφορά τη χρήση του Excel για ανάγνωση και εγγραφή στον Ιστό. Στη σελίδα 335, βρήκα κώδικα που θα μπορούσε να δημιουργήσει ένα ερώτημα ιστού εν κινήσει.
Το πρώτο βήμα ήταν να δω αν μπορούσα να προσαρμόσω τον κώδικα στο βιβλίο για να μπορέσω να δημιουργήσω 27 ερωτήματα ιστού - ένα για καθένα από τα γράμματα του αλφαβήτου και τον αριθμό 1. Αυτό θα μου έδινε αρκετές λίστες με όλους τους συνδέσμους στο 26 αλφαβητικές καταχωρίσεις σελίδων.
Κάθε σελίδα έχει ένα URL παρόμοιο με το http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. Πήρα τον κωδικό από τη σελίδα 335 και το έκανα προσαρμοσμένο για να κάνω 27 ερωτήματα ιστού.
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 SubΥπήρχαν τέσσερα στοιχεία που προσαρμόστηκαν στον παραπάνω κώδικα.
- Πρώτα, έπρεπε να δημιουργήσω τη σωστή διεύθυνση URL. Αυτό επιτεύχθηκε προσθέτοντας το κατάλληλο γράμμα στο τέλος της συμβολοσειράς URL.
- Δεύτερον, τροποποίησα τον κώδικα για να εκτελέσω κάθε ερώτημα σε ένα νέο φύλλο εργασίας στο βιβλίο εργασίας.
- Τρίτον, ο κωδικός στο βιβλίο έπαιρνε τον 20ο πίνακα από την ιστοσελίδα. Καταγράφοντας μια μακροεντολή τραβώντας τον πίνακα από το PMA, έμαθα ότι χρειαζόμουν τον 7ο πίνακα στην ιστοσελίδα.
- Τέταρτον, μετά την εκτέλεση της μακροεντολής, απογοητεύτηκα όταν είχα πάρει τα ονόματα των εκδοτών, αλλά όχι τους υπερσυνδέσμους. Ο κωδικός στο βιβλίο καθορίστηκε .WebFormatting: = xlFormattingNone. Χρησιμοποιώντας τη βοήθεια VBA, κατάλαβα ότι αν άλλαζα σε .WebFormatting: = xlFormattingΌλα, θα έπαιρνα τους πραγματικούς υπερσυνδέσμους.
Μετά την εκτέλεση αυτής της πρώτης μακροεντολής, είχα 27 φύλλα εργασίας, το καθένα με μια σειρά υπερ-συνδέσεων που έμοιαζαν με αυτό:
Το επόμενο βήμα ήταν η εξαγωγή της υπερσυνδεδεμένης διεύθυνσης από κάθε υπερσύνδεση στα 27 φύλλα εργασίας. Δεν υπάρχει στο βιβλίο, αλλά υπάρχει ένα αντικείμενο υπερσύνδεσης στο Excel. Το αντικείμενο έχει μια ιδιότητα .Address που θα επιστρέψει την ιστοσελίδα εντός του PMA-Online με τη διεύθυνση URL για αυτόν τον εκδότη.
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 SubΜετά την εκτέλεση αυτής της μακροεντολής, έμαθα τελικά ότι υπήρχαν 4119 μεμονωμένες ιστοσελίδες στον ιστότοπο PMA. Χαίρομαι που δεν προσπάθησα να επισκεφτώ κάθε μεμονωμένο ιστότοπο κάθε φορά!
Ο επόμενος στόχος μου ήταν να δημιουργήσω ένα webquery για να επισκεφτώ καθεμία από τις 4119 μεμονωμένες ιστοσελίδες. Ηχογράφησα μια μακροεντολή που επιστρέφει μία από τις μεμονωμένες σελίδες εκδοτών για να μάθω ότι ήθελα τον πίνακα # 5 από κάθε σελίδα. Θα μπορούσα να δω ότι το όνομα του εκδότη επιστράφηκε ως η πέμπτη σειρά του πίνακα. Στις περισσότερες περιπτώσεις, ο ιστότοπος επιστράφηκε ως 13η σειρά. Ωστόσο, έμαθα ότι, σε ορισμένες περιπτώσεις, εάν η διεύθυνση του δρόμου ήταν 3 γραμμές αντί για 2, η διεύθυνση URL του ιστότοπου ήταν στην πραγματικότητα στη γραμμή 14. Εάν είχαν 3 τηλέφωνα αντί για 2, ο ιστότοπος σπρώχτηκε κάτω από μια άλλη σειρά. Η μακροεντολή θα πρέπει να είναι αρκετά ευέλικτη για αναζήτηση από ίσως τη σειρά 13 έως 18 για να βρει το κελί που ξεκίνησε το WWW :.
Υπήρχε ένα άλλο δίλημμα. Ο κωδικός στο βιβλίο επιτρέπει στο webquery να ανανεώνεται στο παρασκήνιο. Στις περισσότερες περιπτώσεις, θα παρακολουθούσα πραγματικά την ολοκλήρωση του ερωτήματος μετά την ολοκλήρωση της μακροεντολής. Η αρχική μου σκέψη ήταν να επιτρέψω 40 σειρές για κάθε εκδότη και να δημιουργήσω και τα 4100 ερωτήματα σε κάθε σελίδα. Αυτό θα απαιτούσε 80.000 σειρές υπολογιστικών φύλλων και πολλή μνήμη. Στο Excel 2002, πειραματίστηκα με την αλλαγή του BackgroundRefresh σε False. Η VBA έκανε καλή δουλειά τραβώντας τις πληροφορίες στο φύλλο εργασίας πριν προχωρήσει η μακροεντολή. Αυτό επιτρέπεται να δημιουργηθεί το ερώτημα, να ανανεωθεί το ερώτημα, να αποθηκευτούν οι τιμές σε μια βάση δεδομένων και, στη συνέχεια, να διαγραφεί το ερώτημα. Χρησιμοποιώντας αυτήν τη μέθοδο, δεν υπήρχε ποτέ πάνω από ένα ερώτημα κάθε φορά στο φύλλο εργασίας.
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 SubΑυτό το ερώτημα χρειάστηκε περισσότερο από μία ώρα για να εκτελεστεί. Μετά από όλα, έκανε το έργο της επίσκεψης σε περισσότερες από 4000 ιστοσελίδες. Έτρεξε χωρίς εμπόδιο και δεν έσπασε τον υπολογιστή ή το Excel.
Είχα τότε μια ωραία βάση δεδομένων στο Excel με το όνομα του εκδότη στη στήλη Α και τον ιστότοπο στη στήλη Β. Μετά την ταξινόμηση ανά ιστότοπο στη στήλη Β, διαπίστωσα ότι πάνω από 1000 εκδότες δεν ανέφεραν έναν ιστότοπο. Η καταχώρισή τους στη στήλη Β ήταν μια κενή διεύθυνση URL. Ταξινόμησα και διέγραψα αυτές τις σειρές.
Επίσης, οι ιστότοποι που αναφέρονται στη στήλη Β είχαν το "WWW:" πριν από κάθε διεύθυνση URL. Χρησιμοποίησα μια Επεξεργασία> Αντικατάσταση για να αλλάξω κάθε εμφάνιση του WWW: (με κενό μετά από αυτό) σε τίποτα. Είχα μια ωραία λίστα με 2339 εκδότες σε ένα υπολογιστικό φύλλο.
Το τελευταίο βήμα ήταν να γράψετε ένα αρχείο κειμένου που θα μπορούσε να αντιγραφεί και να επικολληθεί στον ιστότοπο των μελών. Η ακόλουθη μακροεντολή (προσαρμοσμένη από τον κώδικα στη σελίδα 345) χειρίστηκε αυτήν την εργασία όμορφα.
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 SubΤο αποτέλεσμα ήταν ένα αρχείο κειμένου με το όνομα και τη διεύθυνση URL 2000+ εκδοτών.
Όλος ο παραπάνω κώδικας προσαρμόστηκε από το βιβλίο. Όταν ξεκίνησα, ήμουν απλώς να κάνω ένα εφάπαξ πρόγραμμα που δεν οραματίστηκα να τρέχω τακτικά. Ωστόσο, μπορώ τώρα να επιστρέφω στον ιστότοπο PMA κάθε μήνα για να λαμβάνω τις ενημερωμένες λίστες διευθύνσεων URL.
Θα ήταν δυνατόν να τοποθετήσετε όλα τα παραπάνω βήματα σε μία μόνο μακροεντολή.
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 SubΤο Excel και το VBA παρείχαν μια γρήγορη εναλλακτική λύση για την ατομική επίσκεψη χιλιάδων ιστοσελίδων. Θεωρητικά, το PMA θα έπρεπε να ήταν σε θέση να ρωτήσει τη βάση δεδομένων τους και να παράσχει αυτές τις πληροφορίες πολύ πιο γρήγορα από τη χρήση αυτής της μεθόδου. Ωστόσο, μερικές φορές αντιμετωπίζετε κάποιον που δεν συνεργάζεται ή πιθανώς δεν ξέρει πώς να βγάλει δεδομένα από μια βάση δεδομένων που έγραψε κάποιος άλλος για αυτούς. Σε αυτήν την περίπτωση, λίγο από τον κώδικα μακροεντολών VBA έλυσε το πρόβλημά μας.
