Sub Einlesen_MitTabMitTxtInSpalte()
Dim i As Integer
Columns("B:Z").Delete Shift:=xlToLeft
For i = 2 To 11 Step 3
With ActiveSheet.QueryTables.Add(Connection:="TEXT;ftp://tgftp.nws.noaa.gov/data/observations/metar/stations/" & _
Cells(i, 1) & ".TXT", Destination:=Range("B" & i))
.Name = ""
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = True
.TextFileColumnDataTypes = Array(2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next
End Sub
Gruß Jürgen
Hallo Jürgen,
du bist super, Dank dir.
Kannst du mir noch zeigen, wie ich aus so einer Tabelle ein Matrixähnliche Tabelle erstellen kann.
D.H.:
Spalte B soll das Datum stehen (Zeile1 aus dem Internet)
Spalte A soll die Uhrzeit stehen (Zeile 1 aus dem Internet)
Spalte C bis ? soll das stehen, was aus dem Internet (Zeile2) gesaugt wurde
(Bsp. für EDDK: B3-Z3)
Dank und Gruss
mehmet
Ich habe ein Verständnisproblem!
Backowe
Hi mehmet,
wie sieht denn ein Beispiel aus nach dem Download? Kann ich mir jetzt nicht vorstellen.
Gruß Jürgen
AW: Ich habe ein Verständnisproblem!
mehmet
Hier ein Beispiel:
https://www.herber.de/bbs/user/54892.xls
Alles untereinder und sortiert.
Es handelt sich hier um Wetterabfrage aus dem Netz für einige Flughäfen
Der Format ist immer (sollte) gleich sein
Dank dir im Voraus
Gruss
mehmet
AW: Ich habe ein Verständnisproblem!
Backowe
Hi mehmet,
die Datei die Du hochgeladen hast, ist scheinbar das Endprodukt wie die Datei zum Schluß aussehen soll. Aber was mir fehlt sind die Rohdaten direkt nach dem Download, wie sieht da die Datei aus, sonst weiß ich ja nicht was ich anpassen soll.
Gruß Jürgen
AW: Ich habe ein Verständnisproblem!
mehmet
So sollte es jetzt passen!
Backowe
Hi mehmet,
| VBA-Code: | Sub Einlesen2_MitTabMitTxtInSpalte()
Dim Ergebnis As Variant
Dim ImportZeile As String
Dim i As Integer
Columns("B:Z").Delete Shift:=xlToLeft
For i = 2 To 5
With ActiveSheet.QueryTables.Add(Connection:="TEXT;ftp://tgftp.nws.noaa.gov/data/observations/metar/stations/" & _
Cells(i, 1) & ".TXT", Destination:=Range("B" & i))
.Name = ""
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = True
.TextFileColumnDataTypes = Array(2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next
ImportZeile = Cells(i, "B") & " " & Cells(i + 1, "B")
Range(Cells(i, "B"), Cells(i + 1, "B")).ClearContents
Ergebnis = Split(ImportZeile, " ")
For j = 0 To UBound(Ergebnis)
Cells(i, j + 2) = Ergebnis(j)
Next
Next
End Sub
Gruß Jürgen
Kleiner Fehler berichtigt!
Backowe
Hi mehmet,
in die For-Schleife hatte sich ein kleiner Fehler eingeschlichen! ;o)
| VBA-Code: | Sub Einlesen2_MitTabMitTxtInSpalte()
Dim Ergebnis As Variant
Dim ImportZeile As String
Dim i As Integer
Range("B2:Z5").Delete Shift:=xlToLeft
For i = 2 To 5
With ActiveSheet.QueryTables.Add(Connection:="TEXT;ftp://tgftp.nws.noaa.gov/data/observations/metar/stations/" & _
Cells(i, 1) & ".TXT", Destination:=Range("B" & i))
.Name = ""
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = True
.TextFileColumnDataTypes = Array(2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ImportZeile = Cells(i, "B") & " " & Cells(i + 1, "B")
Range(Cells(i, "B"), Cells(i + 1, "B")).ClearContents
Ergebnis = Split(ImportZeile, " ")
For j = 0 To UBound(Ergebnis)
Cells(i, j + 2) = Ergebnis(j)
Next
Next
End Sub
AW: Kleiner Fehler berichtigt!
mehmet
Dank dir Jürgen,
beim einlesen werden die anderen Daten überschrieben statt versetzt.
Hier die Datei:
https://www.herber.de/bbs/user/54899.xls
Eine andere Frage:
1. Kann man es mit einem Datenfilter versehen und nur die Daten Downloaden, die auch zu sehen sind.
Also nicht die ganze Tabelle updaten.
2. Falls eine Fehlermeldung kommt: xxx Datei konnte nicht gefunden werden, diese dann unterdrücken und weiter mit der nächsten abfrage fortfahren (Bsp., Abbruch bei: LESJ).
Dank dir im Voraus
Gruss
mehmet
Ich habe es inzwischen gemerkt!
Backowe
Hi mehmet,
ich habe jetzt mal selbst die Abfrage eingerichtet und das Gleiche festgestellt! Habe jetzt aber keine Zeit mehr, morgen Mittag geht es weiter. ;o)
Gruß Jürgen
AW: Ich habe es inzwischen gemerkt!
mehmet
OK, txs
Hi mehmet,
ich habe Dich nicht vergessen! :)
| VBA-Code: | Sub Einlesen_MitTabMitTxtInSpalte()
Dim Ergebnis As Variant
Dim ImportZeile As String
Dim i As Integer, j As Integer, y As Integer
Application.ScreenUpdating = False
With Sheets("Tabelle1")
.Range("B2:L" & .Cells(.Rows.Count, "A").End(xlUp).Row).ClearContents
End With
Sheets.Add.Name = "Temp"
For i = 2 To 1 + Sheets("Tabelle1").Cells(Sheets("Tabelle1").Rows.Count, "A").End(xlUp).SpecialCells(xlCellTypeVisible).Row
With Sheets("Temp")
.Cells.NumberFormat = "@"
Sheets("Tabelle1").Range("A2:A5").SpecialCells(xlCellTypeVisible).Copy _
Destination:=.Range("A2")
On Error Resume Next
.QueryTables.Add(Connection:="URL;ftp://tgftp.nws.noaa.gov/data/observations/metar/stations/" & _
.Cells(i, "A") & ".TXT", Destination:=.Cells(i, "B")).Refresh BackgroundQuery:=False
If Err = 0 Then
ImportZeile = .Cells(i, "B").Value & " " & .Cells(i + 1, "B").Value
Ergebnis = Split(ImportZeile, " ")
For j = 0 To UBound(Ergebnis)
.Cells(i, j + 2) = Ergebnis(j)
Next
y = Application.Match(.Cells(i, "A"), Sheets("Tabelle1").Range("A1:A" & Sheets("Tabelle1").Cells(Sheets("Tabelle1").Rows.Count, "A").End(xlUp).Row), 0)
.Range("B" & i & ":M" & i).Copy _
Destination:=Sheets("Tabelle1").Range("B" & y)
End If
.Columns("B").Delete
End With
Next
Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Gruß Jürgen
Kleine letzte Korrektur!
Backowe
Hi mehmet,
| VBA-Code: | Sub Einlesen_MitTabMitTxtInSpalte()
Dim Ergebnis As Variant
Dim ImportZeile As String
Dim i As Integer, j As Integer, y As Integer
Application.ScreenUpdating = False
With Sheets("Tabelle1")
.Range("B2:M" & .Cells(.Rows.Count, "A").End(xlUp).Row).ClearContents
End With
For i = 2 To 1 + Sheets("Tabelle1").Cells(Sheets("Tabelle1").Rows.Count, "A").End(xlUp).SpecialCells(xlCellTypeVisible).Row
Sheets.Add.Name = "Temp"
With Sheets("Temp")
.Cells.NumberFormat = "@"
Sheets("Tabelle1").Range("A2:A100").SpecialCells(xlCellTypeVisible).Copy _
Destination:=.Range("A2")
On Error Resume Next
.QueryTables.Add(Connection:="URL;ftp://tgftp.nws.noaa.gov/data/observations/metar/stations/" & _
.Cells(i, "A") & ".TXT", Destination:=.Cells(i, "B")).Refresh BackgroundQuery:=False
If Err = 0 Then
ImportZeile = .Cells(i, "B").Value & " " & .Cells(i + 1, "B").Value
Ergebnis = Split(ImportZeile, " ")
For j = 0 To UBound(Ergebnis)
.Cells(i, j + 2) = Ergebnis(j)
Next
y = Application.Match(.Cells(i, "A"), Sheets("Tabelle1").Range("A1:A" & Sheets("Tabelle1").Cells(Sheets("Tabelle1").Rows.Count, "A").End(xlUp).Row), 0)
.Range("B" & i & ":M" & i).Copy _
Destination:=Sheets("Tabelle1").Range("B" & y)
End If
End With
Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = True
Next
Application.ScreenUpdating = True
End Sub
Gruß Jürgen
AW: Kleine letzte Korrektur!
mehmet
Hallo Jürgen,
was soll ich sagen, du bist super 8-)
Es funktioniert. Dank dir.
Leider sind die Daten nicht sortiert.
Wie könnte man diese noch sortieren?
Alles was mit ....KT oder .....MPS endet unter Wind/Grad (Punkte stehen für Zahlen, wobei ersten 3 Zahlen für Grad und folgend mit Knoten angegeben werden).
alles was mit ../.. oder ./. oder ../. oder ./.. unter Temperature/Dew Point (Temperatur/TauPunkt)
alles was nachfolgend mit Q... oder Q.... beginnt unter Pressure (Luftdruck)
alles was mit NOSIG unter Remarks Spalte.
Ich weis, dass es bischen kompliziert ist, aber eine Sortierung der Daten währe es toll!
Ist das Möglich?
Als Anhang habe ich die Tabelle2 (bereits downgeloaded) mit der Kopfzeile beschriftet.
https://www.herber.de/bbs/user/54935.xls
Dank im Voraus
Herzliche Grüsse
mehmet
Hi mehmet,
| VBA-Code: | Sub Einlesen_MitTabMitTxtInSpalte()
Dim Ergebnis As Variant
Dim ImportZeile As String
Dim i As Integer, j As Integer, y As Integer
Application.ScreenUpdating = False
With Sheets("Tabelle1")
.Range("B2:M" & .Cells(.Rows.Count, "A").End(xlUp).Row).ClearContents
End With
For i = 2 To 1 + Sheets("Tabelle1").Cells(Sheets("Tabelle1").Rows.Count, "A").End(xlUp).SpecialCells(xlCellTypeVisible).Row
Sheets.Add.Name = "Temp"
With Sheets("Temp")
.Cells.NumberFormat = "@"
Sheets("Tabelle1").Range("A2:A200").SpecialCells(xlCellTypeVisible).Copy _
Destination:=.Range("A2")
On Error Resume Next
.QueryTables.Add(Connection:="URL;ftp://tgftp.nws.noaa.gov/data/observations/metar/stations/" & _
.Cells(i, "A") & ".TXT", Destination:=.Cells(i, "B")).Refresh BackgroundQuery:=False
If Err = 0 Then
ImportZeile = .Cells(i, "B").Value & " " & .Cells(i + 1, "B").Value
Ergebnis = Split(ImportZeile, " ")
For j = 0 To UBound(Ergebnis)
.Cells(i, j + 2) = Ergebnis(j)
Next
y = Application.Match(.Cells(i, "A"), Sheets("Tabelle1").Range("A1:A" & Sheets("Tabelle1").Cells(Sheets("Tabelle1").Rows.Count, "A").End(xlUp).Row), 0)
.Range("B" & i & ":M" & i).Copy _
Destination:=Sheets("Tabelle1").Range("B" & y)
End If
End With
Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = True
Next
Application.ScreenUpdating = True
End Sub
Sub Sortieren()
Dim Zelle As Range
Application.ScreenUpdating = True
With Sheets("Tabelle1")
If .FilterMode Then .ShowAllData
.Range("N2:N" & .Cells(.Rows.Count, "A").End(xlUp).Row).Formula = "=OR(RIGHT(F2,2)=""KT"",RIGHT(F2,3)=""MPS"")"
For Each Zelle In .Range("O2:O" & .Cells(.Rows.Count, "A").End(xlUp).Row)
If InStr(Zelle.Offset(0, -5), "/") > 0 Then
Zelle.Value = True
Else
Zelle.Value = False
End If
Next
.Range("P2:P" & .Cells(.Rows.Count, "A").End(xlUp).Row).Formula = "=OR(Left(K2,1)=""Q"",LEFT(L2,5)=""NOSIG"")"
'Beim Sortieren gibt es 3 Möglichkeiten, ich habe "Q" und "NOSIG" zusammengefasst, wenn es nicht passen sollte,
'einfach anpassen!
.Range("A2:Q" & .Cells(.Rows.Count, "A").End(xlUp).Row).Sort Key1:=.Range("N2"), Order1:=xlDescending, Key2:=.Range("O2") _
, Order2:=xlDescending, Key3:=.Range("P2"), Order3:=xlDescending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
.Columns("N:P").Delete shift:=xlLeft
End With
Application.ScreenUpdating = False
End Sub
Gruss Jürgen
AW: Letztes Posting!
mehmet
Hallo Jürgen,
ich danke dir für deine Hilfe
Gruss
mehmet
|
|
|
|
|
|