Jeg har selv brugt det nogle gange, men krak laver om i tingene en gang imellem, så jeg ved ikke hvor længe den holder. Denne virker på privat-personer, så hvis du skal søge på firmaer, skal der nok ændres/tilføjes noget
Indtast tlf nr (Eks. 88888888) i A1 og kør denne makro:
Sub Makro1()
On Error GoTo Næste2
Tlf_Nr = Mid(Range("A1"), 1, 2) & " " & Mid(Range("A1"), 3, 2) & " " & Mid(Range("A1"), 5, 2) & " " & Mid(Range("A1"), 7, 2)
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;
http://www.krak.dk/person/resultat/" & Range("A1"), Destination:=Range("$A$1") _
)
.Name = Range("A1")
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
'.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = False '----
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Navn = Range("A15")
If Mid(Range("A18"), 1, 3) = "Tel" Then
Tlf_Nr2 = Mid(Range("A17"), 27, 12)
Tlf_Nr = Mid(Range("A18"), 5, 11)
Start = 17
Else
Start = 1
End If
For x = Start To Len(Range("A18"))
If Mid(Range("A18"), x, 1) = " " Then
For y = x + 1 To Len(Range("A18"))
If Mid(Range("A18"), y, 1) = " " Then
For Z = y + 1 To Len(Range("A18"))
If Mid(Range("A18"), Z, 1) = " " Then
For q = Z + 1 To Len(Range("A18"))
If Mid(Range("A18"), q, 1) = "." Then
q = q - 3
GoTo Næste
End If
Next
End If
Next
End If
Next
End If
Next
Næste:
Vej = Mid(Range("A18"), Start, (y - Start))
By = Mid(Range("A18"), y + 1, ((q - 1) - y))
Rows("1:60").Delete
Range("A1") = Navn
Range("A2") = Vej
Range("A3") = By
Range("A4") = Tlf_Nr
Range("A5") = Tlf_Nr2
Range("A1:A5").Select
Columns("A:A").EntireColumn.AutoFit
With Selection
.HorizontalAlignment = xlLeft
End With
Range("A1").Select
Exit Sub
Næste2:
Rows("1:600").Delete
Range("A1").Select
MsgBox ("Der er desværre en fejl med det indtastede nr. Prøv igen")
End Sub