Macro to select excel file and to paste

[panthere898]

I need to compare a series of part files that are all in multiple excel files and copy the part number and one set of x,y,z cordinates.
Here is the macro I recorded I just need to be able to select the file to input and past it in the next open cell in the column

Sub Part_Import()
'
' Part_Import Macro
' Imports Part
'


'
Workbooks.Open Filename:= _
"S:\"
Range("E10").Select
Selection.Copy
Windows("Part_Summary.xlsm").Activate
Range("A7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, transpose:=False
Windows("Part_027_081313.xls").Activate
Range("J33:J35").Select
Selection.Copy
Windows("Part_Summary.xlsm").Activate
Range("B7").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, transpose:=True
Windows("Part_027_081313.xls").Close


End Sub

 

[Darren Bartrup]

Welcome to the board,

If all your files are in the same folder you could use this method to cycle through each workbook:

Sub OpenFilesInTurn()

    Dim colFiles As Collection
    Dim myFile As Variant
    Dim wrkbkFile As Workbook
    
    Set colFiles = New Collection
    
    EnumerateFiles "S:\Bartrup-CookD\_Code Library\", "*.xls", colFiles 'Change to your path.


    For Each myFile In colFiles
        Set wrkbkFile = Workbooks.Open(Filename:=myFile, UpdateLinks:=False)
        'Do Stuff
        wrkbkFile.Close SaveChanges:=False
    Next myFile
    


End Sub




Sub EnumerateFiles(ByVal sDirectory As String, _
    ByVal sFileSpec As String, _
    ByRef cCollection As Collection)


    Dim sTemp As String
    
    sTemp = Dir$(sDirectory & sFileSpec)
    Do While Len(sTemp) > 0
        cCollection.Add sDirectory & sTemp
        sTemp = Dir$
    Loop
End Sub

 

[panthere898]

I tried putting my code into that and I dont get any action from it here is how it looks not I got it to paste into the next open cell with just my code running to specific file paths

Sub OpenFilesInTurn()


Dim colFiles As Collection
Dim myFile As Variant
Dim wrkbkFile As Workbook

Set colFiles = New Collection

EnumerateFiles "S:\Quality Control\Left", "*.xls", colFiles 'Change to your path.




For Each myFile In colFiles
Set wrkbkFile = Workbooks.Open(Filename:=myFile, UpdateLinks:=False)
Range("E10").Select
Selection.Copy
wrkbkFile.Activate
Set DestinationCell = Range("A7")
Do While Not IsEmpty(DestinationCell)
Set DestinationCell = DestinationCell.Offset(1, 0)
Loop
DestinationCell.Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
myFile.Activate
Range("J33:J35").Select
Selection.Copy
wrkbkFile.Activate
Set DestinationCell = Range("B7")
Do While Not IsEmpty(DestinationCell)
Set DestinationCell = DestinationCell.Offset(1, 0)
Loop
DestinationCell.Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, transpose:=True
wrkbkFile.Close SaveChanges:=False
Next myFile





End Sub

 

[panthere898]

I think I would rather select the file each time so I can add more in later

 

[Darren Bartrup]

This code will allow you to select a single file.

'---------------------------------------------------------------------------------------
' Procedure : GetFile
' Purpose   : Returns the full file path of the selected file
' To Use    : vFile = GetFile()
'           : vFile = GetFile("S:\Bartrup-CookD\_Code Library")
'---------------------------------------------------------------------------------------
Function GetFile(Optional startFolder As Variant = -1) As Variant
    Dim fle As FileDialog
    Dim vItem As Variant
    Set fle = Application.FileDialog(msoFileDialogFilePicker)
    With fle
        .Title = "Select a File"
        .AllowMultiSelect = False
        .Filters.Add "Excel Files", "*.xls", 1
        If startFolder = -1 Then
            .InitialFileName = Application.DefaultFilePath
        Else
            If Right(startFolder, 1) <> "\" Then
                .InitialFileName = startFolder & "\"
            Else
                .InitialFileName = startFolder
            End If
        End If
        If .Show <> -1 Then GoTo NextCode
        vItem = .SelectedItems(1)
    End With
NextCode:
    GetFile = vItem
    Set fle = Nothing
End Function


Public Sub test()


    Dim vfile As Variant
    
    vfile = GetFile("S:\Bartrup-CookD\_Code Library")


End Sub