Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Znajdź określone pliki, pobierz zawartości do tablicy

stingtanner

Witajcie

Makro oraz plik

Kod:

Option Explicit

Public FileFilter As String

Sub ListFilesTest()

Dim LastRow As Long
Dim rng As Range
Dim wks As Worksheet

FileFilter = "1052107"
If FileFilter = "" Then Exit Sub

FileFilter = "*" & FileFilter & "*"

ListFiles "sciezka do katalogu", Sheets("all").Range("A1"), -1

End Sub

Function ListFiles(ByVal FolderPath As Variant, ByRef OutputCell As Range, Optional ByVal SearchDepth As Long)

' Written: November 07, 2015
' Author: Leith Ross
' SearchDepth = Maximum level (depth) of Subfolders to search.
' 0 = Files in the parent folder only. This is default if no value is given.
' 1,2,3 etc. is maximum level (depth) of Subfolders to search, if that many exist.
' -1 will search all Subfolders of Subfolders, etc.

Dim n As Long
Dim oFile As Object
Dim oFiles As Object
Dim oFolder As Variant
Dim oShell As Object
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lr As Long
Dim trng As Range
Dim t()

If oShell Is Nothing Then
Set oShell = CreateObject("Shell.Application")
End If

Set oFolder = oShell.Namespace(FolderPath)
If oFolder Is Nothing Then
MsgBox "Katalog '" & FolderPath & "' nie istnieje.", vbCritical
SearchDepth = 0
Exit Function
End If

Set oFiles = oFolder.items

n = 0

oFiles.Filter 64, FileFilter
For Each oFile In oFiles
With OutputCell
Set wb1 = Workbooks.Open(oFile.path)
Set ws1 = wb1.Worksheets("Produktion")
lr = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
Set trng = ws1.Range("A3:M" & lr)
If IsEmpty(t) Then
t = trng.Value
Else
'ReDim t(1 To UBound(t) + 1)
'Debug.Print (UBound(t))
't(UBound(t) - 1) = trng.Value
End If
End With
n = n + 1
Next oFile

Set OutputCell = t 'OutputCell.Offset(n, 0)

oFiles.Filter 32, "*"
If SearchDepth <> 0 Then
For Each oFolder In oFiles
Call ListFiles(oFolder, OutputCell, SearchDepth - 1)
Next oFolder
End If

End Function

Makro ma za zadanie znaleźć pliki o określonej na początku nazwie. To działa.
Następnie otwieram 1 znaleziony plik, pobieram z niego wartości, ustawiam "trng" i przypisuję je do tablicy.

Teraz zaczyna sie mój problem.
Szukam kolejny plik, jeśli jest otwieram go, sprawdzam czy t() jest pusta, jeśli nie to chciał bym pobrać z tego nowo otwartego pliku znowu wartości, które przypisały się na nowo do "trng" i dodać je na koniec tablicy (taki lastrow + 1).
W ten sposób mam 2 zakresy w 1 tablicy.

Druga sprawa.
Jak taką tablicę wczytać do pustego arkusza?
czyli w A1 ma się pojawić zawartość całej tablicy. Coś mi dzwoni że Resize, ale jeszcze nie umiem tego obsługiwać.

Laczenie.xlsm

Pobierz Plik ściągnięto 7 raz(y) 24.37 KB

Marecki · Wysłany: 19-02-2021, 08:28

stingtanner, w tych wyszukanych plikach co chcesz pobrać, z jakiego zakresu, z jakiego arkusza ?

stingtanner · Wysłany: 19-02-2021, 08:36

Marecki,
Tu mam podane:

Kod:

Set wb1 = Workbooks.Open(oFile.path)
Set ws1 = wb1.Worksheets("Produktion")
lr = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
Set trng = ws1.Range("A3:M" & lr)

A za pomocą tego:

Kod:

ListFiles "sciezka do katalogu", Sheets("all").Range("A1"), -1

chciał bym wybierać gdzie tablica ma zostać wczytana czyli "Sheets("all").Range("A1")". Jeśli to możliwe, jeśli nie to musi być w funkcji.

Marecki · Wysłany: 19-02-2021, 09:31

Zobacz tak:

Kod:

Option Explicit

Sub test()
Const sSheet As String = "Produktion"
Dim i As Long
Dim lRow As Long
Dim Lista As Variant
Dim sPath As String
Dim sFile As String
Dim sep As String
Dim Tmp As Variant

Call ListFiles("sciezka do katalogu", Lista, "*1052107*.xls*", False) 'Tu dopasuj sobie parametry funkcji

If IsEmpty(Lista) Then
MsgBox "Nie znaleziono plików o danych kryteriach.", vbInformation
Exit Sub
End If

sep = Application.PathSeparator

On Error Resume Next

With Sheets("all")
For i = 1 To UBound(Lista)
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
sPath = Left(Lista(i), InStrRev(Lista(i), sep))
Tmp = Split(Lista(i), sep)
sFile = Tmp(UBound(Tmp))
Erase Tmp
Tmp = ADOGetValue(sPath, sFile, sSheet, "A3:M" & Rows.Count)
.Cells(lRow, 1).Resize(UBound(Tmp), 13).Value = Tmp
Next i
End With

On Error GoTo 0
End Sub

Sub ListFiles(ByVal sFolder As String, ByRef varrFiles As Variant, _
Optional sFilter As String, Optional vSubFolders As Variant)

'---------------------------------------------------------------------------------------
' Procedure : ListFiles
' DateTime : 08.12.2013
' Author : Artik
' Purpose : Procedura listująca nazwy plików (pełne odwołanie) we wskazananym folderze.
' Procedura działa rekurencyjnie.
'
' sFolder - obowiązkowy; wskazany folder
' varrFiles - obowiązkowy; zmienna typu Variant,
' do której zostanie przekazana tablica znalezionych plików
' sFilter - opcjonalny; wzorzec wg którego poszukiwane są pliki
' jl. nie podano - wszystkie pliki
' Przykłady wzorca: "*.xls*" - pliki Excela
' "*Q#*.xls*" - pliki Excela, zawierające w nazwie numer kwartału
' "Raport*.*" - wszystkie pliki, których nazwa rozpoczyna się
' od Raport...
' "[!~]*.xls*" - pliki Excela, bez plików tymczasowych
' vSubFolders - opcjonalny;
' jl. nie podano - a folder zawiera podfoldery, pojawi się pytanie
' czy uwzględnić w poszukiwaniach podfoldery
' True - gdy są podfodery, bezwzględnie je przeszukaj
' False - gdy są podfoldery, bezwzględnie ich NIE przeszukuj
'---------------------------------------------------------------------------------------
'

Dim FSO As Object 'Scripting.FileSystemObject
Dim fsoFolder As Object 'Scripting.Folder
Dim fsoSubFolders As Object 'Scripting.Folders
Dim fsoSubFolder As Object 'Scripting.Folder
Dim fsoFile As Object 'Scripting.File
Dim i As Long

Set FSO = CreateObject("Scripting.FileSystemObject")

If FSO.FolderExists(sFolder) Then
Set fsoFolder = FSO.GetFolder(sFolder)
Set fsoSubFolders = fsoFolder.Subfolders
On Error Resume Next
If fsoSubFolders.Count > 0 Then

If IsMissing(vSubFolders) Then
If MsgBox("Czy uwzględnić podfoldery?", _
vbQuestion + vbYesNo, _
"Lista plików") = vbYes Then
vSubFolders = True
Else
vSubFolders = False
End If
End If

Else
vSubFolders = False

End If 'fsoSubFolders.Count > 0

If Len(sFilter) = 0 Then sFilter = "*.*"

For Each fsoFile In fsoFolder.Files
Application.StatusBar = "Przeszukiwanie folderu: " & fsoFolder.path

If UCase(fsoFile.Name) Like UCase(sFilter) Then
If IsEmpty(varrFiles) Then
ReDim varrFiles(1 To 1)
End If

i = UBound(varrFiles)

If IsEmpty(varrFiles(i)) Then
i = i - 1
End If

i = i + 1

ReDim Preserve varrFiles(1 To i)

varrFiles(i) = fsoFile.path 'pełne odwołanie
'varrFiles(i) = fsoFile.Name 'tylko nazwa pliku z rozszerzeniem

End If 'UCase(fsoFile.Name) Like UCase(sFilter)

Next fsoFile

If vSubFolders Then
For Each fsoSubFolder In fsoSubFolders
Call ListFiles(fsoSubFolder.path, varrFiles, sFilter, True)
Next fsoSubFolder
End If 'vSubFolders = True

End If 'FSO.FolderExists(sFolder) = True

Set fsoSubFolders = Nothing
Set fsoFolder = Nothing
Set FSO = Nothing

Application.StatusBar = False
On Error GoTo 0
End Sub

'http://www.excelforum.pl/topics3/funkcja-getvalue-vt12354.htm?postdays=0&postorder=asc&highlight=%2Aadogetvalue%2A&start=0
Function ADOGetValue(path As String, file As String, sheet As String, ref As String)
' =ADOGetValue(p;f;s;r)
' p - scieżka
' f - nazwa pliku
' s - nazwa arkusza
' r - komórka lub obszar np. "A3", "A1:A10"

Dim arg As String
Dim nRowCount As Long, nColCount As Long
Dim nActRow As Long, nActCol As Long
Dim ArrVal() As Variant
Dim xArray As Variant
Dim xValue As Variant
Dim strConnectionString As String
Dim oCn As Object, oRs As Object

If Right(path, 1) <> "\" Then path = path & "\"

If Dir(path & file) = "" Then
'brak pliku ...
ADOGetValue = CVErr(2042)
Exit Function
End If

Set oCn = CreateObject("ADODB.Connection")

If Val(Application.Version) < 12 Then
strConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & path & file & ";" & _
"Extended Properties=""Excel 8.0;HDR=NO;IMEX=1;"""
Else
strConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & path & file & ";" & _
"Extended Properties=""Excel 12.0;HDR=NO;IMEX=1;"""
End If
oCn.Open strConnectionString
arg = "select * from [" & sheet & "$" & ref & _
IIf(InStr(ref, ":") = 0, ":" & ref, "") & "]"

Set oRs = CreateObject("ADODB.Recordset")

oRs.Open arg, oCn, 3

xArray = oRs.getRows

nRowCount = UBound(xArray, 2)
nColCount = UBound(xArray, 1)

ReDim ArrVal(1 To nRowCount + 1, 1 To nColCount + 1)

For nActRow = 0 To nRowCount

For nActCol = 0 To nColCount

xValue = xArray(nActCol, nActRow)

If IsNumeric(xValue) Then
xValue = CDbl(xValue)
ElseIf IsNull(xValue) Then
xValue = Empty
End If

ArrVal(nActRow + 1, nActCol + 1) = xValue

Next

Next

ADOGetValue = ArrVal

oRs.Close
oCn.Close

Set oRs = Nothing
Set oCn = Nothing

End Function

Kod pobiera dane z zamkniętego pliku.
Dopasuj sobie parametry dla funkcji ListFiles.
Jeśli okaże się że ostatnia komórka w danym pliku nie będzie znajdować się w kolumnie "A" to i tak kod w następnej iteracji nadpisze pobrane dane.
dopiero w ostatniej iteracji będziesz mógł sobie dopisać kod usuwający "nadmiarowe" wiersze, czyli te które są poniżej ostatniej danej w kolumnie "A".

stingtanner · Wysłany: 19-02-2021, 09:46

Marecki,
Łooo ależ to pięknie działa.
Przeszukanie 183 folderów, a w nich 5356 tysięcy plików, zajmuje ~4 sekundy. Czas w pełni akceptowalny.
Chociaż pewnie można to zrobić szybciej :)

Dziękuję bardzo za szybką pomoc.

PS.
Wyłączyłem StatusBar, a czas wyżej jest już bez niego.

stingtanner · Wysłany: 23-02-2021, 10:36

Marecki,
Mógł byś mi pomoc lekko zmodyfikować ww. przez Ciebie kod?

Działa on super dla pojedynczego numeru np. 1052107

Mam arkusz "Email1" (tego samego skoroszytu gdzie jest umieszczone makro), w zakresie U2 -> lastrow jest lista numerów takich jak ten 105 co wyżej.

Chciałbym aby ww. kod brał tą listę numerów, znalazł pliki, pobrał do 1 tablicy i na koniec wczytał wszystko co zebrane.

Czyli ogólnie zasada działania całego marka ta sama, tylko zamiast pojedynczego numeru, lista numerów.

Druga sprawa opcjonalna, jeśli za dużo to poradzę sobie bez tego.
Chciałbym też, aby pobrane dane działały z jednym lub kilkoma warunkami, mianowicie mają zostać pobrane tylko wiersze, gdy zostanie napotkane słowo w kolumnie "P" pobieranego pliku.
Np. jeśli spotkasz w wierszach "AB-CdeFgh" to tylko je pobierz lub lepsze bardziej przyszłościowe, gdybym mógł podać kilka słów i jeśli tylko napotkane było by jedno z nich, to tylko te wiersze ma pobrać.

Marecki

Zamień procedurę test na test_v1

Kod:

Sub test_v1()
Const sSheet As String = "Produktion"
Dim i As Long
Dim j As Long
Dim lRow As Long
Dim Lista As Variant
Dim sPath As String
Dim sFile As String
Dim sep As String
Dim Tmp As Variant
Dim vArr

With Sheets("Email1")
lRow = .Cells(.Rows.Count, "U").End(xlUp).Row
vArr = .Range("U2:U" & lRow).Value
End With

For j = 1 To UBound(vArr)

Call ListFiles("sciezka do katalogu", Lista, "*" & vArr(j, 1) & "*.xls*", False) 'Tu dopasuj sobie parametry funkcji

If IsEmpty(Lista) Then
MsgBox "Nie znaleziono pliku " & "*" & vArr(j, 1) & "*.xls*", vbInformation
GoTo go
End If

sep = Application.PathSeparator

On Error Resume Next

With Sheets("all")
For i = 1 To UBound(Lista)
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
sPath = Left(Lista(i), InStrRev(Lista(i), sep))
Tmp = Split(Lista(i), sep)
sFile = Tmp(UBound(Tmp))
Erase Tmp
Tmp = ADOGetValue(sPath, sFile, sSheet, "A3:M" & Rows.Count)
.Cells(lRow, 1).Resize(UBound(Tmp), 13).Value = Tmp
Next i
End With

On Error GoTo 0
go:
Next j

End Sub

Rafał B.

Czemu:

Kod:

GoTo go

zamiast mniej zakazanego, najzwyklejszego:

Kod:

Else

?

Marecki

Bo było Exit sub i tak jakoś z automatu zamieniłem (było szybciej w napisaniu).
A coś złego jest w takim przeskoczeniu do etykiety ?

Rafał B.

No to jeden z powodów dlaczego VBA jest zawsze bryluje z jakimiś COBOLami w rankingach najbardziej znienawidzonych języków. :mrgreen:

Kolega w wątkach wykazuje się sporym poczuciem humoru i pewnie jestem podpuszczany, ale dzieci czytają, więc trzeba napisać jasno jak niedawno umiejead komuś w wątku: poza obsługą błędów-wyjątków miejsca w dobrym kodzie dla GoTo nie ma. Tu jedno Go, tam drugie i zawsze skończy się na tzw. spaghetti-code, gdzie wszystko się ze sobą wymiesza i nie wiadomo jak to sterowanie leci. Bo zazwyczaj te makra się jednak modyfikuje, rozrastają się, a jak się zaczynają problemy i trzeba kod refaktoryzować, to VBE dysponuje jedynie... CTRL+H. :roll:

Może to nie najlepsze miejsce, ale jest okazja, to coś polecę, bo z łączy się z problemem:
każdy kto na poważnie chce pisać w jakimkolwiek języku powinien przeczytać znany bestseller Roberta Martina Czysty Kod. Czyta się świetnie i chociaż skupia się na OOP i nie dotyczy VBA (w zasadzie abstrahuje raczej od jakiegokolwiek języka), to nawet koderzy "makr" znajdą w niej mnóstwo informacji dla siebie. Jako prowokacyjną zajawkę z tej książki przytoczę zdanie, że każda UDF przyjmująca 2-3 parametry jest podejrzana, a w przypadku większej ilości- na pewno błędnie napisana. Kogo zachęciłem i przeczyta- na pewno mi podziękuje. Ogrom wiedzy i przykładów. Pozdrawiam!

goto.png

Plik ściągnięto 9 raz(y) 25.6 KB

Marecki

Rafał B., pewnie masz rację, ale ja się uczę.
A jak dla mnie przeskok do go czy do else i tak zmienia sterowanie kodu i tak, choć może Else jest bardziej intuicyjne(przyjazne).