Pozdravljeni
Prijatelj me je včeraj spraševal, kako bi nafilu dejavnost za podjetja, ki jih ima shranjena v excelu. Ko sem mu razložil, da se to lahko anrdi z makroji in da pač zahteva neko znanje - ni samo neko klikanje next next next - se je odločil da počaka. Osebno mi pa ni dalo miru in namesto da bi petkov večer preživel bolj ustrezno, sem na hitro sprogramiral makro ki
- gre na stran
- malo klika
- prebere podatke
- shrani v excel
Ne iščem pomoči, ampak samo delim kodo z ostalimi, če bo mogoče kdaj kdo kaj pdoobnega počel in bo rabil pomoč.. zaradi varnosti sem odstranil stran katero parsam
Makro bere vrstico v excelu, potem odpre IE, gre na stran, vpiše ime podjetja v search input ter klikne search. Ko dobi rezultate, klikne na prvi rezultat, gre na predstavitveno stran ter prebero vrednost iz nekega elementa... vmes sem dodal tudi da me zahtevami čaka, da ne bom banan...
Sub IskanjeDejavnosti()
Dim i As Long, Name As String, FoundCompany As Boolean
FoundCompany = False
Set Target = Selection
Dim ie As InternetExplorer
Set ie = New InternetExplorer
Cells(1, 9).Value = "delam ..."
For i = 2 To Target.Rows.Count
If IsEmpty(Cells(i, 8).Value) Then
Name = Cells(i, 4).Value
Cells(1, 9).Value = Name
With ie
.Visible = True
.navigate "http://www.example.com"
Do While .Busy: DoEvents: Loop
Do While .ReadyState <> 4: DoEvents: Loop
Application.Wait Now + TimeSerial(0, 0, 2)
.document.getElementById("ctl00_ContentPlaceHolderLeft_ucSearchCommon_tbSearchWhat").Value = Name
.document.getElementById("ctl00_ContentPlaceHolderLeft_ucSearchCommon_btnSearch").Click
Do While .Busy: DoEvents: Loop
Do While .ReadyState <> 4: DoEvents: Loop
Application.Wait Now + TimeSerial(0, 0, 2)
For Each link In .document.Links
If StringEndsWith(link.ID, "_linkCompany") Then
FoundCompany = True
link.Click
Exit For
End If
Next link
Do While .Busy: DoEvents: Loop
Do While .ReadyState <> 4: DoEvents: Loop
Application.Wait Now + TimeSerial(0, 0, 2)
If FoundCompany Then
Cells(i, 8).Value = .document.getElementById("ctl00_ctl00_ContentPlaceHolderLeft_ContentMain_CompanyDetailsCommon1_CompanySPLPreview1_labMainActivity").innerHTML
Cells(i, 9).Value = "opravil"
Else
Cells(i, 9).Value = "ne najdem podjetja"
End If
End With
FoundCompany = False
Application.Wait Now + TimeSerial(0, 0, 5)
End If
Next i
Set ie = Nothing
Cells(1, 9).Value = "koncal"
End Sub
Public Function StringEndsWith(ByVal strValue As String, _
CheckFor As String, Optional CompareType As VbCompareMethod _
= vbBinaryCompare) As Boolean
'Determines if a string ends with the same characters as
'CheckFor string
'True if end with CheckFor, false otherwise
'Case sensitive by default. If you want non-case sensitive, set
'last parameter to vbTextCompare
'Examples
'MsgBox StringEndsWith("Test", "ST") 'False
'MsgBox StringEndsWith("Test", "ST", vbTextCompare) 'True
Dim sCompare As String
Dim lLen As Long
lLen = Len(CheckFor)
If lLen > Len(strValue) Then Exit Function
sCompare = Right(strValue, lLen)
StringEndsWith = StrComp(sCompare, CheckFor, CompareType) = 0
End Function