Snasui Excel Forum

Code: Select all

Sub ImportSheet()
    Dim sImportFile As String, sFile As String
    Dim sThisBk As Workbook
    Dim vfilename As Variant
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set sThisBk = ActiveWorkbook
    sImportFile = Application.GetOpenFilename( _
    FileFilter:="All Excel Files, *.xls; *.xlsx;*.xlsm;*.csv", Title:="Open Workbook")
    If sImportFile = "False" Then
        MsgBox "No File Selected!"
        Exit Sub
         
    Else
        vfilename = Split(sImportFile, "\")
        sFile = vfilename(UBound(vfilename))
        Application.Workbooks.Open Filename:=sImportFile
         
        Set wbBk = Workbooks(sFile)
        With wbBk
            If SheetExists("Raw_Data") Then
                Set wsSht = .Sheets("Raw_Data")
                wsSht.Copy before:=sThisBk.Sheets("Sheet1")
            Else
                MsgBox "There is no sheet with name :Raw_Data in:" & vbCr & .Name
            End If
            wbBk.Close SaveChanges:=False
        End With
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Private Function SheetExists(sWSName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(sWSName)
    If Not ws Is Nothing Then SheetExists = True
End Function

Code: Select all

Sub collectData()
    Dim wb As Workbook, s As Worksheet, db As Worksheet
    Dim StrPath As Variant, i As Integer, f As Byte
        StrPath = Application.GetOpenFilename(FileFilter:="All Excel Files, *.xls; *.xlsx;*.xlsm;*.csv", _
         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 = Workbooks.Open(StrPath(1))
                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.ScreenUpdating = False
                 Next i
          Application.ScreenUpdating = True
          MsgBox "Finished.", vbInformation
          
End Sub

Code: Select all

Sub collectData()
    Dim wb As Workbook, s As Worksheet, db As Worksheet
    Dim StrPath As Variant, i As Integer, x As Integer
    StrPath = Application.GetOpenFilename(FileFilter:="All Excel Files," _
        & "*.xls; *.xlsx;*.xlsm;*.csv(Comma Separated Values);*.txt", _
        MultiSelect:=True)
    If TypeName(StrPath) = "Boolean" Then Exit Sub
    Set db = ThisWorkbook.Sheets(1)
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For i = 1 To UBound(StrPath)
        Set wb = Workbooks.Open(StrPath(i))
        For Each s In wb.Worksheets
           s.UsedRange.Offset(1, 0).Resize(s.UsedRange.Rows.Count - 1).Copy
           With db
               x = .ListObjects("Table4").Range.Rows.Count
               If .Range("a" & x).Value <> "" Then x = x + 1
               .Range("a" & x).PasteSpecial xlPasteValues
           End With
        Next s
        wb.Close False
        Application.ScreenUpdating = False
    Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub