AW: Makro starten wenn
28.05.2020 10:48:31
UweD
Hallo
Ich habe es mal versucht.
In ein Modul (deins hab ich gekürzt)
Public Aussen As String, Himmel As String, GefTemp As String
Public Wind As String, LuftD As String, LuftF As String, TauP As String
Sub Daten_holen()
Dim TB As Worksheet
Set TB = Sheets("Tabelle2")
With TB.QueryTables.Add(Connection:= _
"URL;http://www.msn.com/de-de/wetter/heute/Brilon,NW,Deutschland/we-city?iso=DE&el= _
fcoUlnFZpeCncBJQVBgUKw%3D%3D&ocid=iehp" _
, Destination:=TB.Range("$A$1"))
.Name = "we-city?iso=DE&el=fcoUlnFZpeCncBJQVBgUKw%3D%3D&ocid=iehp"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
With TB
.Columns(1).Delete
.Columns(2).Delete
Aussen = .Cells(1, 1) & " °"
Himmel = .Cells(2, 1)
GefTemp = Mid(.Cells(3, 1), 21)
Wind = Mid(.Cells(4, 1), 10)
LuftD = Mid(.Cells(5, 1), 11)
LuftF = Mid(.Cells(6, 1), 18)
TauP = Mid(.Cells(7, 1), 10)
End With
End Sub
In den Codebereich der Tabelle1
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Fehler
Const APPNAME = "Worksheet_Change"
Dim Sp As Integer, Ze As Integer
Sp = 11 'ab K
If Not Intersect(Range("A:J"), Target) Is Nothing Then
Ze = Target.Row
If Cells(Ze, Sp) = "" Then
Daten_holen
Application.EnableEvents = False
Cells(Ze, Sp) = Aussen
Cells(Ze, Sp + 1) = Himmel
Cells(Ze, Sp + 2) = GefTemp
Cells(Ze, Sp + 3) = Wind
Cells(Ze, Sp + 4) = LuftD
Cells(Ze, Sp + 5) = "'" & LuftF ' wegen Formatierung mit %
Cells(Ze, Sp + 6) = TauP
End If
End If
'*** Fehlerbehandlung
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
& "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub
Sobald in einer Neuen Zeile im Vorderen Bereich was eingetragen wird (Spalte A bis J) wird geprüft, ob in K schon was steht.
Wenn nicht, werden die Daten geholt und eingetragen
LG UweD
