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

Recently Active Members

Profile picture of vbatools
Profile picture of Karol Stilger
Profile picture of marcinmachalowski
Profile picture of Joanna Subik
Profile picture of Anorak
Profile picture of programistaaccess
Profile picture of piotrpawlik
Profile picture of Emil Wasilewski
Profile picture of kicekpicek
Profile picture of coldfusion
Profile picture of Gosia Borzęcka
Profile picture of lukaszch
Profile picture of itadministracja
Profile picture of farbenia
Profile picture of Łukasz Kałużny
Profile picture of kabzinski
Profile picture of rtynski
Profile picture of leszekbetlinski
Profile picture of Iv
Profile picture of Justyna Spychała