Morgen Ivan,
ich weiss gar nicht wie ich Dir danken soll.
Nur zur Vervollständigung es handelt sich um den Laufzeitfehler 1004 aus VBA!
Die Prozedur funktioniert soweit, dass kein Fehler kommt. Das Programm zieht mir beim ersten Mal jetzt zwar keine Daten mehr, dass ist aber kein Problem. Ich werde einfach eine Startprozedur entwickeln die ich beim öffnen der Datei ausführen lasse. Danach funktioniert das Makro ja einwandfrei. Hauptsache der Fehler taucht nicht mehr auf!
Noch einmal herzlichen Dank!!!
- Hätte zwar trotzdem gerne gewusst woran es lag - aber das scheint mal wieder eines dieser Geheimnisse von VBA zu sein!
Bis bald
Gruß
Jens
ps: Als kleiner Dank ein Großteil des Programms, vielleicht kannst Du es mal gebrauchen.
(Einige Teile habe ich dank der Hilfe der Forumsteilnehmer so zusammengestellt; auch wenn ich mitlerweile einiges anders ansteuern würde!)
Sub Abfrage()
' Abfrage Makro
' Tastenkombination: Strg+t
'Löschen der vorhandenen Abfrage
Dim Ergebnis
Dim Filenum As Integer
Dim Monat As String
Dim Tag As String
Dim Datum As Long
Dim Datum1 As Long
Dim Datum2 As String
Dim Datum3 As String
Dim Zeile As Long
Dim Pu1 As String
Dim Pu2 As String
Dim Pu3 As String
Sheets(2).Select
Zeile = Cells(65536, 1).End(xlUp).Row
Range("X" & Zeile).Select
ActiveCell.FormulaR1C1 = "=MID(RC[-23],1,2)"
Range("Y" & Zeile).Select
ActiveCell.FormulaR1C1 = "=MID(RC[-24],4,2)"
'folgender Tag
Datum = Cells(Zeile, 24)
Datum1 = Cells(Zeile, 25)
Datum2 = Datum + 1
If Datum = 1 Then Datum2 = "02"
If Datum = 2 Then Datum2 = "03"
If Datum = 3 Then Datum2 = "04"
If Datum = 4 Then Datum2 = "05"
If Datum = 5 Then Datum2 = "06"
If Datum = 6 Then Datum2 = "07"
If Datum = 7 Then Datum2 = "08"
If Datum = 8 Then Datum2 = "09"
'Monatsende
If Datum = 31 And Datum1 = 1 Then Datum2 = "01"
If Datum = 28 And Datum1 = 2 Then Datum2 = "01"
If Datum = 31 And Datum1 = 3 Then Datum2 = "01"
If Datum = 30 And Datum1 = 4 Then Datum2 = "01"
If Datum = 31 And Datum1 = 5 Then Datum2 = "01"
If Datum = 30 And Datum1 = 6 Then Datum2 = "01"
If Datum = 31 And Datum1 = 7 Then Datum2 = "01"
If Datum = 31 And Datum1 = 8 Then Datum2 = "01"
If Datum = 30 And Datum1 = 9 Then Datum2 = "01"
If Datum = 31 And Datum1 = 10 Then Datum2 = "01"
If Datum = 30 And Datum1 = 11 Then Datum2 = "01"
If Datum = 31 And Datum1 = 12 Then Datum2 = "01"
'Monat
Datum1 = Cells(Zeile, 25)
Datum3 = "0" & Datum1
If Datum1 = 10 Then Datum3 = "10"
If Datum1 = 11 Then Datum3 = "11"
If Datum1 = 12 Then Datum3 = "12"
'Monatsende
If Datum1 = 12 And Datum = 31 Then Datum3 = "01"
If Datum1 = 1 And Datum = 31 Then Datum3 = "02"
If Datum1 = 2 And Datum = 28 Then Datum3 = "03"
If Datum1 = 3 And Datum = 31 Then Datum3 = "04"
If Datum1 = 4 And Datum = 30 Then Datum3 = "05"
If Datum1 = 5 And Datum = 31 Then Datum3 = "06"
If Datum1 = 6 And Datum = 30 Then Datum3 = "07"
If Datum1 = 7 And Datum = 31 Then Datum3 = "08"
If Datum1 = 8 And Datum = 31 Then Datum3 = "09"
If Datum1 = 9 And Datum = 30 Then Datum3 = "10"
If Datum1 = 10 And Datum = 31 Then Datum3 = "11"
If Datum1 = 11 And Datum = 30 Then Datum3 = "12"
Filenum = FreeFile()
Dim Dateiname As String
pfadname$ = "C:\TEMP\*.*"
Dateiname$ = Dir$(pfadname, 0)
Do While Dateiname$ <> ""
If LCase(Dateiname$) = "lua tageswerte.iqy" Then
Kill Left(pfadname, 8) & "LUA Tageswerte.iqy"
Exit Do
End If
Dateiname$ = Dir$()
Loop
'Schreiben der neuen Abfrage
Open Left(pfadname, 8) & "LUA Tageswerte.iqy" For Append As Filenum
Print #Filenum, "WEB"
Print #Filenum, "1"
Monat = InputBox("Geben Sie den zu downloadenden Monat an (Format: MM [z.B. 06]).", "Monat definieren", Datum3)
If Monat = "" Then Exit Sub
Tag = InputBox("Geben Sie den zu downloadenden Tag an (Format: DD [z.B. 22]).", "Tag definieren", Datum2)
If Tag = "" Then Exit Sub
' Wenn eine andere Messstelle benötigt wird einfach die Stelle DUBR.html ersetzen. Kürzel ist auf Auswahlseite angegeben!
Print #Filenum, "http://www.lua.nrw.de/luft/temes/" & Monat & Tag & "/WALS.htm"
Close Filenum
Sheets(1).Select
Range("A1").Select
Columns("A:G").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
With ActiveSheet.QueryTables.Add(Connection:= _
"FINDER;C:\TEMP\LUA Tageswerte.iqy", Destination:= _
Range("A1"))
On Error Resume Next
If Err.Number <> 0 Then
End If
.FieldNames = False
.RefreshStyle = xlInsertDeleteCells
.RowNumbers = False
.FillAdjacentFormulas = False
.RefreshOnFileOpen = False
.HasAutoFormat = True
.BackgroundQuery = True
.TablesOnlyFromHTML = True
.Refresh BackgroundQuery:=False
.SavePassword = False
.SaveData = True
End With
Sheets(1).Select
Range( _
"8:8,10:10,12:12,14:14,16:16,18:18,20:20,22:22,24:24,26:26,28:28,30:30,32:32,34:34" _
).Select
Range("A34").Activate
Range( _
"8:8,10:10,12:12,14:14,16:16,18:18,20:20,22:22,24:24,26:26,28:28,30:30,32:32,34:34,36:36,38:38,40:40,42:42,44:44,46:46,48:48,50:50,52:52,54:54,55:55" _
).Select
Range("A55").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("A8:B31").Select
Range("A31").Activate
Selection.Copy
Sheets(2).Select
Range("A1").Select
Pu1 = Zeile + 24
Pu2 = Zeile + 25
Pu3 = Zeile + 47
Range("A" & Pu1).Activate
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.Orientation = 0
.ShrinkToFit = False
.MergeCells = False
End With
Range("A" & Pu1 & ":A" & Pu3).Select
Range("A" & Pu3).Activate
'Diesen Filter eventuell neu machen! Makro aufzeichnen und entsprechende Zeilen daraus kopieren!
'Bitte folgendes ersetzen, damit es automatisch funktioniert: Selection.TextToColumns Destination:=Range("A" & Pu1),
Selection.TextToColumns Destination:=Range("A" & Pu1), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(8, 1), Array(15, 1), Array(21, 1), Array(26, 1), _
Array(31, 1), Array(37, 1), Array(43, 1), Array(51, 1), Array(57, 1), Array(64, 1))
'Filter Ende
Rows(Pu1 & ":" & Pu3).Select
Range("A" & Pu3).Activate
Rows(Pu1 & ":" & Pu3).EntireRow.AutoFit
Range("A" & Pu1 & ":A" & Pu3).Select
Range("A" & Pu3).Activate
Selection.ClearContents
Range("A" & Pu1).Select
ActiveCell.FormulaR1C1 = Tag & "." & Monat & "."
With ActiveCell.Characters(Start:=1, Length:=7).Font
.Name = "Courier New"
.FontStyle = "Standard"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("A" & Pu1 & ":K" & Pu3).Select
Range("A" & Pu3).Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A1").Select
'"-" löschen
Range("A" & Pu1 & ":D" & Pu3).Select
Selection.Replace What:="-", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Range("F" & Pu1 & ":K" & Pu3).Select
Selection.Replace What:="-", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Range("A1").Select
Sheets(1).Select
Range("A4:B4").Select
Selection.Copy
Sheets(2).Select
Range("N" & Pu1).Select
ActiveSheet.Paste
Range("X" & Zeile).Select
Selection.ClearContents
Range("Y" & Zeile).Select
Selection.ClearContents
Range("B" & Pu1).Select
End Sub
pps: Um es so wie hier auszuführen musst Du in Tabelle2 in A1 z.B. 04.08. schreiben. Viel Spass!!!