none
Copy range of cells from closed workbooks RRS feed

  • Question

  • Hi,

    Is there a way to loop thru a folder (That have Excel files) and for each workbook find the last row and copy a specific range (that is changing since each workbook has different last row) to target workbook without opening the files.

    I did a loop that opens each one of the files, calculates the last row and copy the range to the target workbook, then the workbook is closed and going to the next file.

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set folder = FSO.GetFolder(PathName)

    For Each file In folder.Files
            Workbooks.Open file
            Call CopyFromSimFile    'Copy a specific range    
            ActiveWorkbook.Close savechanges:=False
    Next file


    Guy Zommer

    Sunday, February 26, 2012 9:23 AM

Answers

All replies

  • That posible, but performance is not a good thing about this method.

    1st GetValue Function

    Sub getValie()
    Dim P As String
    Dim F As String
    Dim s As String
    Dim r As Long, c As Long
    Dim a, ile_wierszy As Long, ile_kolumn As Long
    
    P = Left(FileName, Len(FileName) - Len(Dir(FileName)) - 1)
    F = Dir(FileName)
    s = "Arkusz1"
    ile_wierszy = 0
    Application.ScreenUpdating = False
    'sprawdzenie ile jest wierszy
        For r = 1 To Cells(Rows.Count, 1).End(xlUp).Row
            a = Cells(r, 1).Address
            If GetValue(P, F, s, a) <> 0 Then
                ile_wierszy = ile_wierszy + 1
            Else
                Exit For
            End If
        Next r
    'sprawdzenie ile jest kolumn
        For c = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
            a = Cells(1, c).Address
            If GetValue(P, F, s, a) <> 0 Then
                ile_kolumn = ile_kolumn + 1
            Else
                Exit For
            End If
        Next c
    'kopiowanie danych
        For r = 1 To ile_wierszy
            For c = 1 To ile_kolumn
                a = Cells(r, c).Address
                If GetValue(P, F, s, a) = 0 Then
                    Cells(r, c) = ""
                Else
                    Cells(r, c) = GetValue(P, F, s, a)
                End If
            Next c
        Next r
    Application.ScreenUpdating = True
    End Sub
    Private Function GetValue(path, file, sheet, ref)
    Dim Arg As String
    
    If Right(path, 1) <> "\" Then path = path & "\"
    If Dir(path & file) = "" Then
        GetValue = "Plik nie został znaleziony."
        Exit Function
    End If
    
    Arg = "'" & path & "[" & file & "]" & sheet & "'!" & Range(ref).Range("a1").Address(, , xlR1C1)
    GetValue = ExecuteExcel4Macro(Arg)
    End Function

    2nd SQL Method

    Sub Importuj()
    Dim ok As Boolean
    Dim MyFile$: MyFile = "C:\Temp\test ok.xlsx"
    Dim MyName$: MyName = "aaa"
    
    ok = tabela(MyFile, MyName, Rows(Rows.Count).End(xlUp).Row)
    Debug.Print ok
    End Sub
    
    Function tabela(ByVal MyFile$, MyName$, Optional MyEndStart&) As Boolean
    Dim MyPath$: MyPath = Left(MyFile, InStrRev(MyFile, "\"))
    If Len(MyEndStart) = 0 Or MyEndStart = 1 Then MyEndStart = 0
    If InStr(1, MyName, " ") Then MyName = "'" & MyName & "$'"
    On Error GoTo blad
        With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array( _
            Array("ODBC;DSN=Excel Files;DBQ=" & MyFile & ";"), _
            Array("DefaultDir=" & MyPath & ";DriverId=1046;MaxBufferSize=2048;"), _
            Array("PageTimeout=5;")), _
            Destination:=Range("$A$" & MyEndStart + 1)).QueryTable
            .CommandText = Array("SELECT * FROM `" & MyFile & "`.`" & MyName & "`")
            .Refresh BackgroundQuery:=False
        End With
    tabela = True
    Exit Function
    blad:
    tabela = False
    End Function


    Oskar Shon, Office System MVP

    Press if Helpful; Answer when a problem solved

    Sunday, February 26, 2012 4:17 PM
    Answerer
  • If your data is usefully structured in Excel, then the last row number isn't needed. Try reading:

    http://support.microsoft.com/kb/278973


    Rod Gill

    The one and only Project VBA Book Rod Gill Project Management

    Sunday, February 26, 2012 7:52 PM
  • Guy  and what, do you try eny method?

    Oskar Shon, Office System MVP

    Press if Helpful; Answer when a problem solved

    • Marked as answer by Guy Zommer Wednesday, February 29, 2012 4:47 AM
    Tuesday, February 28, 2012 10:02 PM
    Answerer
  • Thanks

    Guy Zommer

    • Marked as answer by Guy Zommer Wednesday, February 29, 2012 4:49 AM
    Wednesday, February 29, 2012 4:49 AM