Snasui Excel Forum

Code: Select all

Sub CollectDataFromMultiFile()
    Dim wb As Workbook, s As Worksheet, db As Worksheet
    Dim strPath As Variant, i As Integer, f As Byte
    strPath = Application.GetOpenFilename( _
        FileFilter:="Excel File (*.xls*),*.xls*", _
        MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    Set db = ThisWorkbook.Sheets("Total")
    db.UsedRange.ClearContents
    Application.ScreenUpdating = False
    For i = 1 To UBound(strPath)
        Set wb = Workbooks.Open(strPath(i))
        For Each s In wb.Worksheets
            f = IIf(db.Range("a1").Value = "", 0, 1)
            If s.Range("a1").Value <> "" Then
                s.UsedRange.Offset(f, 0).Copy
                With db
                    .Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
                        .PasteSpecial xlPasteValues
                End With
            End If
        Next s
        wb.Close
        Application.CutCopyMode = False
    Next i
    Application.ScreenUpdating = True
    MsgBox "Finished", vbInformation
End Sub

Code: Select all

Sub ListFileInFolder()
Directory = "D:\Anamai\SystemTest\TestForm\*.xlsx"
r = 2
ListFile = Dir(Directory, vbNormal)
    Do While ListFile <> ""
    r = r + 1
    Cells(r, 2) = ListFile
    ListFile = Dir()
    Loop
End Sub

Code: Select all

Sub Colletcdata()
    Dim myFolder As String, mySubFolder As String
    Dim wb As Workbook, s As Worksheet, db As Worksheet
    Dim strPath As Variant, i As Integer, f As Byte
    myFolder = "D:\Anamai\TestVBA\DataTest"
    mySubFolder = Dir(myFolder & "*", vbDirectory)
    strPath = Application.GetOpenFilename(FileFilter:="Excel File(*.xls*),*.xls*", _
        MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    Set db = ThisWorkbook.Sheets(1)
    db.UsedRange.ClearContents
    Application.ScreenUpdating = False
    For i = 1 To UBound(strPath)
        Set wb = Workbook.Open(strPath(i))
        For Each s In wb.Worksheets
            f = IIf(db.Range("a1").Value = "", 0, 1)
            If s.Range("a1").Value <> "" Then
               s.UsedRange.Offset(f, 0).Copy
                With db
                    .Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
                        .PasteSpecial xlPasteValues
                End With
            End If
         Next s
         wb.Close False
         Application.CutCopyMode = False
    Next i
    Apllication.ScreenUpdating = True
    MsgBox "Finished.", vbInformation
End Sub