VBATools

Kopiowanie plików tekstowych tworząc kwerendę

by on Nov.09, 2011, under Excel, Porady

Przypuśćmy iż mamy wiele plików TXT w dowolnym katalogu. Pliki te mogą się zmieniać (pochodzą z eksportu zewnętrznego).

Założeniem jest iż pliki posiadają nazwę “Nazwisko Imię, reszta opisu.txt“.

Każdy arkusz (dla każdego pliku tekstowego) z zaimportowanymi danymi powinien nazywać się jak pierwszy człon nazwy pliku tekstowego.

Po pobraniu danych opcja odświeżania ma być dostępna pod prawym klawiszem myszy dla każdego połączenia lub komendą ActiveWorkbook.RefreshAll, dla wszystkich zbiorczo.

Sub FilesTXTetFolder()
'MVP OShon from VBATools.pl
Dim ob As Object, pliki As Object, plik As Object
Dim folder As Object, sciezka$, nazwa_arkusza$, wks As Worksheet
sciezka = "C:\Temp" 

Set ob = CreateObject("Scripting.FilesystemObject")
Set folder = ob.GetFolder(sciezka)
Set pliki = ob.GetFolder(folder).Files

With Application
 .ScreenUpdating = False
 .EnableEvents = False
 For Each plik In pliki
 If Mid(LCase(plik), InStrRev(plik, ".") + 1, 3) = "txt" Then
 If InStr(1, plik.Name, ",") Then
 nazwa_arkusza = Split(plik.Name, ",")(0)
 Else
 If InStr(1, plik.Name, ".") Then nazwa_arkusza = Split(plik.Name, ".")(0)
 End If
 For Each wks In ThisWorkbook.Worksheets
 If wks.Name = nazwa_arkusza Then GoTo juz_jest 'zamiast opuszczenia można wymazać stary arkusz.
 Next wks

 Sheets.Add After:=Sheets(Sheets.Count)
 ActiveSheet.Name = nazwa_arkusza
 With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & sciezka & plik.Name, _
 Destination:=Range("$A$1"))
 .Name = nazwa_arkusza
 .RefreshStyle = xlInsertDeleteCells
 .SaveData = True
 .Refresh BackgroundQuery:=False
 End With
 End If
juz_jest:
 Next plik
 .ScreenUpdating = True
 .EnableEvents = True
End With
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