GetValue i odczyt wartości z określonego zakresu
w każdym z plików xls w danym folderze.
  strona główna:
A po co ten Excel ;-)
 
 
    Najczęściej ja sam własną stronę traktuję jak FAQ. Publikując takie procedury które są albo w całości moją pracą albo, w których  
według mnie wprowadziłem jakąś istotną zmianę, ale najważniejsze: często ktoś ma problem który w danym artykule omawaim.  
    I tym razem będzie nie inaczej.  
 
Zadanie brzmi: "W określnym folderze znajduje się pewna ilość plików xls. Jak zaimportować z tych plików dane, które znajdują się w   
                     "arkuszu o nazwie ark1 i zakresie B1:B6 do nowego, zbiorczego pliku xls. Każdy zakres z poszczególnych plików do  
                     "nowej kolumny."  
 
Do odczytu wartości z zamkniętego pliku xls może posłużyć nam funkcja GetValue wykorzystująca metodę ExecuteExcel4Macro.   A VBA Function To Get A Value From A Closed File
Moja przeróbka tej funkcji polega na tym żeb funkcja może zwrócić tablicę wartości z zakresu komórek, a nie pojedyńczą wartość.  
 
Private Function GetValue(path As String, _  
                          file As String, _  
                          sheet As String, _  
                          ref As String)  
                           
    Dim w As Long, k As Integer  
    Dim tbl() As Variant, i As Long, j As Integer  
 
    With Application.Range(ref)  
        w = .Rows.Count  
        k = .Columns.Count  
    End With  
     
    ReDim tbl(1 To w, 1 To k)  
 
    For i = 1 To w  
        For j = 1 To k  
            tbl(i, j) = ExecuteExcel4Macro("'" & path & _  
                                           "[" & file & "]" & _  
                                           sheet & "'!" & _  
                                           Application.Range(ref).Cells(i, j).Address(, , xlR1C1))  
        Next  
    Next  
    GetValue = tbl  
End Function  
 
W funkcji nie sprawdzam:  
 - czy plik istnieje. Przez wzgląd na fakt że nazwę pliku określi procedura zewnętrzna ustaloająca nazwy plików xls z folderu.  
 - czy ścieżka folderu została zakończona znakiem \ . Jak ktoś chce proszę sobie dopisać :-P  
 
    Potrzebuję tablicę z nazwami plików o zadanym rozszerzeniu z określonego folderu:  
 
Function vFileNames(strFolderPAth As String, strLike As String) As Variant  
    Dim objFSO As Object 'Scripting.FileSystemObject  
    Dim objFolder As Object 'Scripting.Folder  
    Dim objFile As Object 'Scripting.file  
    Dim tblFileNames() As String, i As Integer  
 
    Set objFSO = CreateObject("Scripting.FileSystemObject")  
    Set objFolder = objFSO.GetFolder(strFolderPAth)  
     
    For Each objFile In objFolder.Files  
        If objFile.Name Like strLike Then  
            ReDim Preserve tblFileNames(i)  
            tblFileNames(i) = objFile.Name  
            i = i + 1  
        End If  
    Next  
    If i > 0 Then  
        vFileNames = tblFileNames  
    End If  
     
    Set objFSO = Nothing  
    Set objFolder = Nothing  
    Set objFile = Nothing  
     
End Function  
 
Na realizację tego zadania jest przynajmniej kilka sposobów jednak ja do prcay na plikach/folderach zwykle wykorzystuję bibliotekę  
Scripting.Runtime. Funkcja przyjmuje argumenty: strFolderPAth - ścieżkę folderu z plikami, strLike - wzór nazwy pliku.  
    No i przykładowa procedura importująca dane z plików xls do arkusza "Zbiorczy" od kolumny B w prawo.  
 
Sub Start()  
    Const strFolderPAth As String = "C:\moje dane\"  
    Const strArkName As String = "Ark1"  
     
    Dim tblFiles As Variant, i As Integer  
    Dim xlWks As Excel.Worksheet, tblDane As Variant  
    Dim iCol As Integer: iCol = 2  
     
    tblFiles = vFileNames(strFolderPAth, "*.xl*")  
    If IsArray(tblFiles) Then  
         
        Set xlWks = ThisWorkbook.Worksheets("Zbiorczy")  
     
        For i = 0 To UBound(tblFiles)  
            xlWks.Cells(1, iCol).Resize(6, 1) = GetValue(strFolderPAth, CStr(tblFiles(i)), strArkName, "B1:B6")  
            iCol = iCol + 1  
        Next  
    End If  
             
End Sub  
 
Enjoi :-)