Microsoft Office Forums - View Single Post

Catalin.B · 07-22-2012, 10:48 AM

This is the code you will find in the file attached. Just press the start button , in the browse window that comes up, navigate to the folder that contains your source files and double click any file from that folder; the code opens every file from that folder and copies cells A58 to column D.

Code:

Option Explicit
Sub ChangeLinks()
Application.ScreenUpdating = False
Dim NewLnk As String
 
NewLnk = Application.GetOpenFilename("Excel files,*.xl*", _
                           1, "Choose any file in the source folder", , False)
                           
       If TypeName(NewLnk) = "Boolean" Then Exit Sub
       
    Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")

Dim Fisier, FolderSursa As String, LastRow As Long
LastRow = ThisWorkbook.Sheets("1000000").Range("D" & Rows.Count).End(xlUp).Row
  FolderSursa = oFSO.GetFile(NewLnk).ParentFolder
         For Each Fisier In oFSO.GetFolder(FolderSursa).Files
            Workbooks.Open (Fisier)
            ActiveSheet.Cells(58, "A").Copy
            ThisWorkbook.Activate
            ThisWorkbook.Sheets("1000000").Cells(LastRow + 1, "D").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
            Workbooks(Fisier.Name).Close savechanges:=False
            LastRow = LastRow + 1
         Next
         
 
End Sub