Bir gün, PMA'da Jan'den bir yayın e-postası aldım. Clearbridge Publishing'den Gary Gagliardi'den harika bir fikir iletiyordu. Gary, bazı arama motorlarının sayfaya diğer kaç sitenin bağlantı verdiğine bağlı olarak bir sayfaya bir sayfa sıralaması atadığından bahsetti. PMA'nın 4000 üyesinin tamamı PMA'nın diğer 4000 üyesine bağlanırsa, tüm sıralamalarımızı yükselteceğini öne sürüyordu. Jan bunun harika bir fikir olduğunu düşündü ve tüm PMA üye web adreslerinin üyeler alanındaki mevcut PMA web sitesinde listelendiğini söyledi.
Kişisel olarak, "bağlantı sayısı" teorisinin biraz efsane olduğunu düşünüyorum, ancak yardım etmek için onu denemeye istekliydim.
Bu yüzden, tek bir üye listesi olmadığını, aslında 27 üye listesi olduğunu çabucak öğrendiğim PMA Üyeleri alanını ziyaret ettim.
"A" sayfasına tıkladığımda, daha da kötü olduğunu gördüm. Bu sayfadaki her bağlantı üyenin web sitesine gitmemiştir. Buradaki her bağlantı, üyenin web sitesi ile PMA-online'da ayrı bir sayfaya götürür.
Bu, üye listesini derlemek için binlerce web sayfasını ziyaret etmem gerektiği anlamına gelir. Bu açıkça çılgınca bir önerme olurdu.
Neyse ki, Microsoft Excel için VBA & Makrolar'ın ortak yazarıyım. Binlerce bağlantılı sayfadan üye URL'lerini çıkarma sorununu çözmek için kitaptaki kodu özelleştirip özelleştiremeyeceğimi merak ettim.
Kitabın 14. Bölümü, web'den okumak ve web'e yazmak için Excel'i kullanmakla ilgilidir. 335. sayfada, anında bir web sorgusu oluşturabilecek bir kod buldum.
İlk adım, kitaptaki kodu 27 web sorgusu üretebilecek şekilde özelleştirip özelleştiremeyeceğimi görmekti - alfabedeki harflerin her biri ve 1 rakamı için bir tane. Bu bana sayfadaki tüm bağlantıların birkaç listesini verecektir. 26 alfabetik sayfa listesi.
Her sayfanın http://www.pma-online.org/scripts/showmemlist.cfm?letter=A'ya benzer bir URL'si vardır. 335 sayfasından kod aldım ve 27 web sorgusu yapmak için biraz özelleştirdim.
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 SubYukarıdaki kodda özelleştirilen dört öğe vardı.
- İlk olarak, doğru URL'yi oluşturmam gerekiyordu. Bu, URL dizesinin sonuna uygun harf eklenerek sağlandı.
- İkinci olarak, kodu her sorguyu çalışma kitabındaki yeni bir çalışma sayfasında çalıştıracak şekilde değiştirdim.
- Üçüncüsü, kitaptaki kod, 20. tabloyu web sayfasından alıyordu. PMA'dan tablo çekerek bir makro kaydederek web sayfasındaki 7. tabloya ihtiyacım olduğunu öğrendim.
- Dördüncüsü, makroyu çalıştırdıktan sonra, yayıncıların adlarını aldığımı, ancak köprüleri almadığımı görünce hayal kırıklığına uğradım. Kitaptaki kod belirtildi .WebFormatting: = xlFormattingNone. VBA yardımını kullanarak, .WebFormatting: = xlFormattingAll olarak değiştirirsem, gerçek köprüleri alacağımı düşündüm.
Bu ilk makroyu çalıştırdıktan sonra, her biri şuna benzeyen bir dizi köprü içeren 27 çalışma sayfam vardı:
Bir sonraki adım, 27 çalışma sayfasındaki her köprüden köprülü adresi çıkarmaktı. Kitapta yok ama Excel'de bir köprü nesnesi var. Nesne, PMA-Online içindeki web sayfasını o yayıncının URL'siyle döndürecek bir .Address özelliğine sahiptir.
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 SubBu makroyu çalıştırdıktan sonra, sonunda PMA sitesinde 4119 ayrı web sayfası olduğunu öğrendim. Her bir siteyi teker teker ziyaret etmeye çalışmadığım için mutluyum!
Bir sonraki hedefim, 4119 ayrı web sayfasının her birini ziyaret etmek için oluşturulmuş bir web sorgusuna sahip olmaktı. Her sayfadan 5 numaralı tablo istediğimi öğrenmek için yayıncı sayfalarından birini döndüren bir makro kaydettim. Yayıncı adının tablonun beşinci satırı olarak döndürüldüğünü görebiliyordum. Çoğu durumda, web sitesi 13. satır olarak döndürüldü. Ancak, bazı durumlarda, açık adres 2 yerine 3 satır ise, web sitesinin URL'sinin aslında 14. satırda olduğunu öğrendim. 2 yerine 3 telefonu varsa, web sitesi başka bir satıra itildi. WWW: 'yi başlatan hücreyi bulmak için makronun belki satır 13'den 18'e kadar arama yapacak kadar esnek olması gerekir.
Başka bir ikilem vardı. Kitaptaki kod, web sorgusunun arka planda yenilenmesine izin verir. Çoğu durumda, makro bittikten sonra sorgunun bittiğini izlerdim. İlk düşüncem, her yayıncı için 40 satıra izin vermek ve her sayfada 4100 sorgunun tümünü oluşturmaktı. Bu, 80.000 satırlık elektronik tablo ve çok fazla bellek gerektirirdi. Excel 2002'de BackgroundRefresh'i False olarak değiştirmeyi denedim. VBA, makro devam etmeden önce bilgileri çalışma sayfasına çekme konusunda iyi bir iş çıkardı. Bu, sorguyu oluşturmaya, sorguyu yenilemeye, değerleri bir veritabanına kaydetmeye ve ardından sorguyu silmeye izin verdi. Bu yöntemi kullanarak, çalışma sayfasında aynı anda birden fazla sorgu olmamıştır.
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 SubBu sorgunun çalıştırılması bir saatten fazla sürdü. Ne de olsa 4000'den fazla web sayfasını ziyaret etme işini yapıyordu. Sorunsuz çalıştı ve bilgisayarı veya Excel'i çökertmedi.
Daha sonra Excel'de, Yayıncı adı A sütununda ve web sitesi B sütununda olan güzel bir veritabanım vardı. B Sütununda web sitesine göre sıraladıktan sonra, 1000'den fazla yayıncının bir web sitesini listelemediğini gördüm. B sütunundaki girişleri boş bir URL idi. Bu satırları sıralayıp sildim.
Ayrıca, B sütununda listelenen web sitelerinde her URL'den önce "WWW:" vardı. WWW'nin her oluşumunu (arkasından bir boşlukla) hiçbir şeyle değiştirmek için Düzenle> Değiştir'i kullandım. Bir elektronik tabloda 2339 yayıncıdan oluşan güzel bir listem var.
Son adım, herhangi bir üyenin web sitesine kopyalanıp yapıştırılabilecek bir metin dosyası yazmaktı. Aşağıdaki makro (sayfa 345'teki koddan uyarlanmıştır) bu görevi güzelce yerine getirdi.
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 SubSonuç, 2000'den fazla yayıncının adını ve URL'sini içeren bir metin dosyasıydı.
Yukarıdaki kodun tamamı kitaptan uyarlanmıştır. Başladığımda, düzenli olarak çalışmayı hayal etmediğim tek seferlik bir program yapıyordum. Bununla birlikte, güncellenmiş URL listelerini almak için her ay PMA web sitesine geri dönerek görüntüleyebiliyorum.
Yukarıdaki adımların tümünü tek bir makroya yerleştirmek mümkün olacaktır.
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 ve VBA, binlerce web sayfasını tek tek ziyaret etmeye hızlı bir alternatif sağladı. Teoride, PMA'nın veritabanını sorgulayabilmesi ve bu bilgiyi bu yöntemi kullanmaktan çok daha hızlı sağlayabilmesi gerekirdi. Bununla birlikte, bazen işbirliği yapmayan veya muhtemelen başkasının kendisi için yazdığı bir veritabanından nasıl veri alınacağını bilmeyen biriyle uğraşıyorsunuz. Bu durumda, biraz VBA makro kodu sorunumuzu çözdü.
