Snasui Excel Forum

Code: Select all

Sub Imds()
    Dim PathFolder As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select a Folder"
        .Filters.Clear
        .AllowMultiSelect = False
        .InitialFileName = ""
    
       If .Show = -1 Then
           If Right(.SelectedItems(1), 1) = "\" Then
                PathFolder = .SelectedItems(1)
            Else
                PathFolder = .SelectedItems(1)
           End If
            wsI = PathFolder
        End If
        Range("C4").Select
        ActiveCell.FormulaR1C1 = PathFolder
    End With
    Call Dataimport
End Sub

Function Dataimport()
    Dim wbO As Workbook
    Dim wbI1 As Workbook
    Dim wsI1 As Worksheet
    Dim wsI2 As Worksheet
    Dim wsI3 As Worksheet
    Dim im As String
    Set wbI1 = ThisWorkbook
    Set wsI1 = wbI1.Sheets("Dataimport1")
    Set wsI2 = wbI1.Sheets("Dataimport2")
    Set wsI3 = wbI1.Sheets("Dataimport3")
    im = Sheets("Home").Range("C4")
    If im = "" Then
        MsgBox "Cancel Import Data"
        GoTo X
    End If
    Set wbO = Workbooks.Open(im)
    wsI1.Range("A:A").Value = wbO.Sheets(1).Range("F:F").Value
    wsI1.Range("B:B").Value = wbO.Sheets(1).Range("B:B").Value
    wsI1.Range("C:C").Value = wbO.Sheets(1).Range("G:G").Value
    wsI1.Range("D:D").Value = wbO.Sheets(1).Range("K:K").Value
    wsI2.Range("A:A").Value = wbO.Sheets(2).Range("F:F").Value
    wsI2.Range("B:B").Value = wbO.Sheets(2).Range("B:B").Value
    wsI2.Range("C:C").Value = wbO.Sheets(2).Range("G:G").Value
    wsI2.Range("D:D").Value = wbO.Sheets(2).Range("K:K").Value
    wsI3.Range("A:A").Value = wbO.Sheets(3).Range("F:F").Value
    wsI3.Range("B:B").Value = wbO.Sheets(3).Range("B:B").Value
    wsI3.Range("C:C").Value = wbO.Sheets(3).Range("G:G").Value
    wsI3.Range("D:D").Value = wbO.Sheets(3).Range("K:K").Value
    wbO.Close SaveChanges:=False
X:
End Function

Code: Select all

Sub Imds()
Dim PathFolder As String
With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Select a Folder"
    .Filters.Clear
    .AllowMultiSelect = False
    .InitialFileName = ""

   If .Show = -1 Then
       If Right(.SelectedItems(1), 1) = "\" Then
            PathFolder = .SelectedItems(1)
        Else
            PathFolder = .SelectedItems(1)
       End If
        wsI = PathFolder
    End If
    Range("C4").Select
    ActiveCell.FormulaR1C1 = PathFolder
End With
Call Dataimport
End Sub
Function Dataimport()
    Dim wbO As Workbook
    Dim wbI1 As Workbook
    Dim wbI2 As Workbook
    Dim wbI3 As Workbook
    Dim wsI1 As Worksheet
    Dim wsI2 As Worksheet
    Dim wsI3 As Worksheet
    Dim im As String
    Set wbI1 = ThisWorkbook
    Set wsI1 = wbI1.Sheets("Dataimport1")
    Set wbI2 = ThisWorkbook
    Set wsI2 = wbI2.Sheets("Dataimport2")
    Set wbI3 = ThisWorkbook
    Set wsI3 = wbI3.Sheets("Dataimport3")
    im = Sheets("Home").Range("C4")
    If im = "" Then
        MsgBox "Cancel Import Data"
        GoTo X
        End If
    Set wbO = Workbooks.Open(im)
    wbO.Sheets(1).Range("F:F").Cells.Copy wsI1.Cells.Range("A:A")
    wbO.Sheets(1).Range("B:B").Cells.Copy wsI1.Cells.Range("B:B")
    wbO.Sheets(1).Range("G:G").Cells.Copy wsI1.Cells.Range("C:C")
    wbO.Sheets(1).Range("K:K").Cells.Copy wsI1.Cells.Range("D:D")
    wbO.Sheets(2).Range("F:F").Cells.Copy wsI2.Cells.Range("A:A")
    wbO.Sheets(2).Range("B:B").Cells.Copy wsI2.Cells.Range("B:B")
    wbO.Sheets(2).Range("G:G").Cells.Copy wsI2.Cells.Range("C:C")
    wbO.Sheets(2).Range("K:K").Cells.Copy wsI2.Cells.Range("D:D")
    wbO.Sheets(3).Range("F:F").Cells.Copy wsI3.Cells.Range("A:A")
    wbO.Sheets(3).Range("B:B").Cells.Copy wsI3.Cells.Range("B:B")
    wbO.Sheets(3).Range("G:G").Cells.Copy wsI3.Cells.Range("C:C")
    wbO.Sheets(3).Range("K:K").Cells.Copy wsI3.Cells.Range("D:D")
    wbO.Close SaveChanges:=False
X:
End Function