Witam
Procedura importu plików:
1. Z adresu skopiuj dane na pulpit
http://bossa.pl/pub/futures/mstock/mstfut.zip
2. Rozpakuj, zostaw w katalogu mstfut pliki, które chcesz importować.
3. Otwórz skoroszyt
4. Do moduły w skoroszycie wstaw poniższe 2 makra: Import plików i
Aktualizacja sesji
5. Zmień ścieżki dostępu do plików na swoje:
Directory = "C:\Documents and Settings\Darek\Pulpit\mstfut\"
nazPliku = "C:\Documents and Settings\Darek\Pulpit\sesjafut.prn"
6. Uruchom makro Import plików skopiują się dane z katalogu mstfut
Procedura aktualizacji sesji
1. Z adresu
http://bossa.pl/pub/futures/mstock/s...t/sesjafut.prn należy
skopiować plik aktualizacyjny na pulpit
2. Uruchom makro aktualizacja sesji i to już koniec
Sub Import_Plików()
Dim Directory As String
Dim f As String
Dim kryt
Dim Sh As Worksheet, xNazwa As Object
Dim xConect As Object
Directory = "C:\Documents and Settings\Darek\pulpit\mstfut\"
f = Dir(Directory, 7)
Application.ScreenUpdating = False
Do While f <> ""
Sheets.Add.Name = Left(f, Len(f) - 4)
With ActiveSheet
With .QueryTables.Add(Connection:="TEXT;" & Directory & f,
Destination:=Range("A1"))
.TextFileCommaDelimiter = True
.TextFileDecimalSeparator = "."
.TextFileColumnDataTypes = Array(1, 5, 1, 1, 1, 1, 1)
.Refresh BackgroundQuery:=False
End With
Columns("A").Delete
End With
f = Dir
Loop
' Usuwanie połączeń
For Each xConect In ActiveWorkbook.Connections
If UCase(xConect.Name) Like "*" Then xConect.Delete
Next xConect
'Usuwanie nazw
For Each Sh In ActiveWorkbook.Worksheets
For Each xNazwa In Sh.Names
xNazwa.Delete
Next xNazwa
Next Sh
End Sub
Sub Aktualizacja_Sesji()
Application.ScreenUpdating = False
Dim nazPliku As String
Dim numPliku As Integer
Dim nazArkusza As String
Dim arkusz As Worksheet
Dim linia As String
Dim dane As Variant
Dim ostWiersz As Long
Dim data As Date
nazPliku = "C:\Documents and Settings\Darek\Pulpit\sesjafut.prn"
numPliku = FreeFile
Open nazPliku For Input As numPliku
Do While Not EOF(numPliku)
Line Input #numPliku, linia
dane = Split(linia, ",")
nazArkusza = dane(0)
On Error Resume Next
Set arkusz = Sheets(nazArkusza)
On Error GoTo 0
If Not arkusz Is Nothing Then
data = DateSerial( _
Left(dane(1), 4), Mid(dane(1), 5, 2), Right(dane(1), 2))
With arkusz
ostWiersz = .Cells(Rows.Count, "A").End(xlUp).Row
If .Cells(ostWiersz, "A") < data Then
ostWiersz = ostWiersz + 1
'.Cells(ostWiersz, "A") = nazArkusza
.Cells(ostWiersz, "A") = data
.Cells(ostWiersz, "B") = Val(dane(2))
.Cells(ostWiersz, "C") = Val(dane(3))
.Cells(ostWiersz, "D") = Val(dane(4))
.Cells(ostWiersz, "E") = Val(dane(5))
.Cells(ostWiersz, "F") = Val(dane(6))
.Cells(ostWiersz, "G") = Val(dane(7))
End If
End With
Set arkusz = Nothing
End If
Loop
Close numPliku
End Sub
Pozdrawiam
DeJotTe
kontrakty-excel 
Linear Mode
