AW: automatischer Import - Fragen
25.05.2008 15:51:00
fcs
Hallo Maris,
trage die anderen Währungen in den Spalten der Zeile 1 ein.
Ich hab die Hauptprozedur wie folgt angepasst, so dass die Spalten mit den Wärungskürzeln in For-Next -Schleifen abgearbeitet werden. Die letzte Spaltennummer muss du im Code noch anpassen.
Gruß
Franz
Sub KursImport()
'Kurse einlesen aus Text-Dateien im Verzeichnis bis zum aktuellen Datum
Dim objWks As Worksheet
Dim lngZeile As Long, lngSpalte As Long
Dim datDatumWks As Date, datDatumTxt As Date, strDatum As String
Dim strDateiKurse As String
Dim bolNeu As Boolean
Set objWks = ThisWorkbook.Worksheets(1)
With objWks
'Letze Zeile und Datum in Tabelle ermitteln
lngZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
If lngZeile = 1 Then
'Es sind noch keine Kurse eingetragen
'Kurse aus allen vorhandenen Text-Dateien einlesen
'Suchstring für Dir-Funktion
strDateiKurse = strVerzKursTxt + Application.PathSeparator _
& strDateiKurseAnfang & "*.txt"
'Dateien suchen
strDateiKurse = Dir(pathname:=strDateiKurse, Attributes:=vbNormal)
If strDateiKurse = "" Then
strMsg = "im Verzeichnis """ & strVerzKursTxt _
& """ sind keine Wechselkursdateien vorhanden!"
lngBoxButton = vbOKOnly + vbInformation
MsgBox Prompt:=strMsg, Buttons:=lngBoxButton, Title:=strBoxTitel
GoTo Beenden
Else
bolNeu = True
Do Until strDateiKurse = ""
'Datum aus dem Dateinamen ermitteln
strDatum = Mid(strDateiKurse, 14, 8)
'Datum eintragen
lngZeile = lngZeile + 1
If IsDate(strDatum) Then
.Cells(lngZeile, 1).Value = CDate(strDatum)
Else
.Cells(lngZeile, 1).Value = strDatum
End If
'Verzeichnis zum Dateinamen hinzufügen
strDateiKurse = strVerzKursTxt + Application.PathSeparator & strDateiKurse
For lngSpalte = 2 To 17 '17 entspechend letzte Spalte mit Währung anpassen###
'Kurs für Währung in Zeile 1 der Spalte einlesen
.Cells(lngZeile, lngSpalte).Value = fncKurs_Import(strWaehrung:= _
.Cells(1, lngSpalte).Value, strTxtDatei:=strDateiKurse)
Next
strDateiKurse = Dir
Loop
'Einträge nach Datum sortieren
.Range(.Cells(2, 1), .Cells(lngZeile, 3)).Sort _
Key1:=.Cells(2, 2), Order1:=xlAscending, Header:=xlNo
End If
Else
'letztes eingetragenes Datum
datDatumWks = .Cells(lngZeile, 1).Value
'Text-Dateien bis zum aktuellen Datum suchen
For datDatumWks = datDatumWks + 1 To Date
strDateiKurse = strVerzKursTxt + Application.PathSeparator _
& strDateiKurseAnfang & Format(datDatumWks, "DD.MM.YY") & ".txt"
If Dir(pathname:=strDateiKurse, Attributes:=vbNormal) = "" Then
'do nothing, keine Datei vorhanden
Else
bolNeu = True 'Neue Dateien gefunden
'Datum eintragen
lngZeile = lngZeile + 1
.Cells(lngZeile, 1).Value = datDatumWks
For lngSpalte = 2 To 17 '17 entspechend letzte Spalte mit Währung anpassen###
'Kurs für Währung in Zeile 1 der Spalte einlesen
.Cells(lngZeile, lngSpalte).Value = fncKurs_Import(strWaehrung:= _
.Cells(1, lngSpalte).Value, strTxtDatei:=strDateiKurse)
Next
End If
Next
End If
If bolNeu = True Then
strMsg = "Wechselkurs Daten wurden aktualisert." & vbLf & vbLf _
& "Letztes gefundenes Datum: " & Format(.Cells(lngZeile, 1).Value, "D. MMMM, YYYY")
Else
strMsg = "Es wurden keine aktuellen Wechselkurs Daten gefunden." & vbLf & vbLf _
& "Letztes Datum: " & Format(.Cells(lngZeile, 1).Value, "D. MMMM, YYYY")
End If
lngBoxButton = vbOKOnly + vbInformation
MsgBox Prompt:=strMsg, Buttons:=lngBoxButton, Title:=strBoxTitel
End With
Beenden:
'Datei speichern
If ThisWorkbook.Saved = False Then ThisWorkbook.Save
'Fehlerbehandlung
Fehler:
If Err.Number 0 Then
strMsg = "Fehler-Nummer: " & Err.Number & vbLf & Err.Description _
& vbLf & vbLf & "Prozedur: KursImport"
lngBoxButton = vbOKOnly + vbExclamation
MsgBox Prompt:=strMsg, Buttons:=lngBoxButton, Title:=strBoxTitel
End If
'Objekte und Application-Einstellungen zurücksetzen
End Sub