znalazłem sobie skoroszyt w Excel'u, który pobiera kursy walut NBP. Jako niewolnik CHF-ów bardzo mi się przyda ten skoroszyt w Calc. Mam problem z konwersją z VBA do StarBasic'a. Z góry dziękuję za pomoc. Dołączam oryginalny skoroszyt.
A to makra:
Kod: Zaznacz cały
Option Explicit
Sub Waluty()
Dim rName As Name
Dim ost, i As Long
Dim tabela, nrTabeli As String
Dim data_tabeli As Date
Dim Index
Dim zapyt As QueryTable
If Worksheets("Kursy").Range("A2").Value = Date Then Exit Sub
Worksheets("Kursy").Range("K7") = "Czekaj !!! Pobieram dane"
Application.ScreenUpdating = False
pobierz_dir ' pobieram spis tabel kursów
ost = Worksheets("Dir").Range("A65536").End(xlUp).Row
For i = 1 To ost
tabela = Worksheets("Dir").Cells(i, 1)
data_tabeli = DateSerial(Val("20" & Mid(tabela, 6, 2)), Val(Mid(tabela, 8, 2)), Val(Mid(tabela, 10, 2)))
If Left(tabela, 1) = "a" And data_tabeli > #1/1/2010# Then
' ograniczę lekko zakres, żeby nie ściągać za długo - można powyżej wpisać inną datę
' pierwsza tabela na NBP w formacie jakie akceptuje to makro jest z 04.05.2004
Index = Application.Match(tabela, Worksheets("Kursy").Range("B:B"), 0) ' sprawdzam czy pobrałem już takie tabele
If IsError(Index) Then ' jeżeli nie
nrTabeli = Mid(tabela, 2, 3) & "/" & UCase(Left(tabela, 1)) & "/NBP/" & ("20" & Mid(tabela, 6, 2))
With Worksheets("Waluty")
.Select
.Columns("A:F").Clear
.Range("A1") = data_tabeli
.Range("B1") = tabela 'oryginalny
.Range("C1") = nrTabeli ' przekształcony
End With
With Worksheets("Waluty").QueryTables.Add(Connection:= _
"URL;http://www.nbp.pl/Kursy/TabArch.aspx?n=" & tabela, Destination:=Range("A2"))
.Name = "Kursy" & tabela
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = False
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "2"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
UpdateCell
End If
End If
Next
For Each rName In ActiveWorkbook.Names
rName.Delete
Next rName
For Each zapyt In Worksheets("Waluty").QueryTables
zapyt.Delete
Next
Worksheets("Kursy").Select
With Worksheets("Kursy").Range("A1:J" & Worksheets("Kursy").Range("A65536").End(xlUp).Row)
.Sort Key1:=Range("A2"), Order1:=xlDescending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
Application.ScreenUpdating = True
Worksheets("Kursy").Range("K7") = ""
End Sub
Kod: Zaznacz cały
Sub UpdateCell()
'Niniejsza procedura UpdateCell jest wykonana przez Tajana - ja tylko dostosowałem do swoich potrzeb :)
'Tajan - Mam nadzieję, że się nie gniewasz
Dim data As Double
Dim poz
Dim kwer As Worksheet
Dim zest As Worksheet
Dim kol As Long
Dim wiersz As Long
Dim tabo, tabl As String
Set kwer = ThisWorkbook.Worksheets("Waluty")
Set zest = ThisWorkbook.Worksheets("Kursy")
data = Range("A1") ' data tabeli
tabo = Range("B1") ' nazwa oryginalna tabeli w NBP
tabl = Range("C1") ' nazwa przetworzona tabeli
With zest
poz = Application.Match(data, .Range("A:A"), 0)
If IsError(poz) Then
poz = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End If
kol = 4
.Cells(poz, "A") = CDate(data)
.Cells(poz, "B") = tabo
.Cells(poz, "C") = tabl
Do While .Cells(1, kol) <> ""
wiersz = Application.Match(.Cells(1, kol), kwer.Range("B:B"), 0)
.Cells(poz, kol) = kwer.Cells(wiersz, "C")
kol = kol + 1
Loop
End With
End Sub
Kod: Zaznacz cały
Sub pobierz_dir()
With Worksheets("Dir")
.Select
.Columns(1).Delete
End With
With Worksheets("Dir").QueryTables.Add(Connection:= _
"URL;http://www.nbp.pl/kursy/xml/dir.txt", Destination:=Range("A1"))
.Name = "dir-kursy"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Sub
Kod: Zaznacz cały
Sub usun()
If MsgBox("Czy na pewno chcesz usunąć wszystkie dane ?", vbInformation + vbYesNo) <> vbYes Then Exit Sub
ost = [A65536].End(xlUp).Row
If ost > 2 Then
Range("A2:I" & ost).ClearContents
End If
End Sub