VBATools

Pobranie do arkusza danych z plików tekstowych

by on Dec.20, 2011, under Excel, Porady

Przypuśćmy że mamy listę plików tekstowych, każdy z nich różni się od siebie nazwą i zawartością. Chcielibyśmy przenieść ich zawartość w uszeregowaną grupę danych do arkusza Excela. Otwieranie każdego pliku i kopiowanie jego zawartości troszkę będzie kłopotliwe w przypadku gdy powiadamy znaczną ilość rozpatrywanych plików. Możemy przyjąć też iż nie wszystkie z plików będą brane pod uwagę – np. tylko te, które mają w nazwie element wyróżniający (może to być inny wyróżnik, lub nie musi on być w cale). Przyjmijmy jednak że pliki jakie chcemy analizować będą miały w nazwie dwie litery “PL”. Posłuży nam do tego możliwość zastosowania późnego wiązania kontrolki FSO, która jest ogólnie dostępna w większości systemów MS.

Postać pliku tekstowego to kilka linijek, np:

Nazwa prowadzącego: Nowak Adam
Data pomiaru: 2011-01-03
Liczba próbek: 6
Łączny czas trwania 5:21
Maszyna nr: 2

Lista danych w pliku tekstowym oraz wielkość pliku może być dowolna ponieważ będziemy analizować każdą linię pliku. Załóżmy że w zadaniu chcemy pobrać tylko cześć z tych danych (lub wszystkie zależy od ilości warunków). Pobrane dane możemy na etapie przypisania do komórek dowolnie modulować używając funkcji wew VB6 lub własnych. Ilość i czas zapisu danych jest proporcjonalny, a dla większej ilości plików można dodać komunikat w StatusBar’ze o postępującym działaniu. Uruchomienie poniższego kodu pobiera dane i począwszy od wpisania w aktywny arkusz nagłówka będzie osadzał dane w kolejnych wierszach:

Sub import_danych_z_TXT()
'MVP OShon from VBATools.pl
Const sciezka As String = "c:\Temp" 'ścieżka z której będą brane pliki - zmodyfikuj
With Cells(1, 1)
 .Value = "Data pomiaru"
 .Offset(, 1) = "Maszyna"
 .Offset(, 2) = "Czas trwania"
End With

 Dim objFSO    As Object
 Dim objFolder As Object
 Dim ObjPlik   As Object
 Dim pobrany$, x&: x = 2
 Dim F%: F = FreeFile()

 Application.ScreenUpdating = False
 Set objFSO = CreateObject("Scripting.FileSystemObject")
 Set objFolder = objFSO.GetFolder(sciezka)

 For Each ObjPlik In objFolder.Files
  If ObjPlik.Name Like "*PL*" Then   'Ograniczenie - jakie pliki będą brane pod uwagę
   Open sciezka & ObjPlik.Name For Input As #F
   Do While Not EOF(F)
    Line Input #F, pobrany  'Analizujemy konkretne linie i przypisujemy je do celi
    If InStr(1, pobrany, "Data pomiaru:") > 0 Then _
     Cells(x, 1).Value = Application.Trim(Split(pobrany, "Data pomiaru:")(1))
    If InStr(1, pobrany, "Maszyna nr:") > 0 Then _
     Cells(x, 2).Value = Application.Trim(Split(pobrany, "Maszyna nr:")(1))
    If InStr(1, pobrany, "Łączny czas trwania") > 0 Then _
     Cells(x, 3).Value = Application.Trim(Split(pobrany, "Łączny czas trwania")(1))
   Loop
   Close #F
   x = x + 1
  End If
 Next

 Application.ScreenUpdating = True
 Set objFSO = Nothing
 Set objFolder = Nothing
 Set ObjPlik = Nothing
End Sub

(c) Shon Oskar – www.VBATools.pl

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.
:, , , ,

Leave a Reply