Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 70184 Skopiuj do schowka Znajdź określone pliki, pobierz zawartości do tablicy
Autor Wiadomość
stingtanner
Stały bywalec Excelforum


Wersja: Win Office 2013
Pomógł: 6 razy
Posty: 497
Wysłany: 19-02-2021, 08:05   Znajdź określone pliki, pobierz zawartości do tablicy

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

ID posta: 400662 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2494 razy
Posty: 8280
Wysłany: 19-02-2021, 08:28   

stingtanner, w tych wyszukanych plikach co chcesz pobrać, z jakiego zakresu, z jakiego arkusza ?
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 400664 Skopiuj do schowka
 
 
stingtanner
Stały bywalec Excelforum


Wersja: Win Office 2013
Pomógł: 6 razy
Posty: 497
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.
ID posta: 400665 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2494 razy
Posty: 8280
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".
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 400667 Skopiuj do schowka
 
 
stingtanner
Stały bywalec Excelforum


Wersja: Win Office 2013
Pomógł: 6 razy
Posty: 497
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.
  
ID posta: 400669 Skopiuj do schowka
 
 
stingtanner
Stały bywalec Excelforum


Wersja: Win Office 2013
Pomógł: 6 razy
Posty: 497
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ć.
ID posta: 400873 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2494 razy
Posty: 8280
Wysłany: Wczoraj 19:29   

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
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 400955 Skopiuj do schowka
 
 
Rafał B.
Exceloholic



Wersja: Win Office 2016
Pomógł: 33 razy
Posty: 232
Wysłany: Wczoraj 20:17   

Czemu:
Kod:
GoTo go

zamiast mniej zakazanego, najzwyklejszego:
Kod:
Else

? ;-)
_________________
Jest niemal niemożliwe nauczenie dobrego programowania uczniów, którzy byli narażeni na kontakt z BASIC: jako potencjalni programiści są okaleczeni, bez nadziei na poprawę. (Edsger Dijkstra, pionier informatyki).
Po części dotyczy również VBA.
  
ID posta: 400956 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2494 razy
Posty: 8280
Wysłany: Wczoraj 20:25   

:lol: :lol: 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 ?
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
  
ID posta: 400957 Skopiuj do schowka
 
 
Rafał B.
Exceloholic



Wersja: Win Office 2016
Pomógł: 33 razy
Posty: 232
Wysłany: Wczoraj 21:22   

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

_________________
Jest niemal niemożliwe nauczenie dobrego programowania uczniów, którzy byli narażeni na kontakt z BASIC: jako potencjalni programiści są okaleczeni, bez nadziei na poprawę. (Edsger Dijkstra, pionier informatyki).
Po części dotyczy również VBA.
  
ID posta: 400959 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2494 razy
Posty: 8280
Wysłany: Wczoraj 22:59   

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).

Rafał B. napisał/a:
Kolega w wątkach wykazuje się sporym poczuciem humoru i pewnie jestem podpuszczany
Nie, nie, taki już mam "spaczony" charakter. ;-)
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 400964 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe