Kopiowanie plików tekstowych tworząc kwerendę
by vbatools 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.