[Tasos]

Καλησπέρα!

Δημήτρη δοκίμασε τον παρακάτω κώδικα (όλος ο κώδικας της λειτουργικής μονάδας):

Option Explicit
Private Const MyPC = 0&
Private Const ShOptions = 65&

Function FolderBrowserDialog() As String
    Dim oShell As Object
    Dim oFolder As Object
    Set oShell = CreateObject("Shell.Application")
    Set oFolder = oShell.BrowseForFolder( _
                  Application.Hwnd, "Επιλέξτε το φάκελο με τα αρχεία προς αναζήτηση" & vbLf & _
                                    "και πατήστε 'ΟΚ'." & vbLf & _
                                    "Πατήστε 'Ακυρο'για να ακυρώσετε την ενέργεια." _
                                    & vbLf, ShOptions, MyPC)
    If Not oFolder Is Nothing Then
        FolderBrowserDialog = oFolder.Self.Path
    End If
    Set oFolder = Nothing
    Set oShell = Nothing
End Function

Sub SetFolderPath()
    Dim strPath As String
    strPath = FolderBrowserDialog
    If strPath = "" Or Left(strPath, 1) = ":" Then Exit Sub
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    Range("WBPath") = strPath
End Sub

Sub SyncValues()
    Dim wb As Workbook
    Dim wks As Worksheet
    Dim ThisWks As Worksheet
    Dim WbNamesRange As Range
    Dim SourceRange As Range
    Dim TargetRange As Range
    Dim WBPath As String
    Dim WBName As String
    Dim i As Integer
    On Error GoTo ExitHere
    Set ThisWks = ActiveSheet
    WBPath = Range("WBPath")
    If Right(WBPath, 1) <> "\" Then WBPath = WBPath & "\"
    Set WbNamesRange = Range("WBNames")
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    For i = 1 To WbNamesRange.Rows.Count
        If Trim(WbNamesRange(i).Offset(, -1).Value) = vbNullString Then
            WBName = WBPath & WbNamesRange(i).Value
            Set wb = Workbooks.Open(WBName, , True)
            Set wks = wb.Worksheets(1)
            wks.Cells.UnMerge

            Set SourceRange = wks.Range(wks.Range("A3"), wks.Range("AJM" & _
                                wks.Range("A" & wks.Rows.Count).End(xlUp).Row))
                                
            Set TargetRange = ThisWks.Range("C" & Rows.Count).End(xlUp).Offset(1) _
                              .Resize(SourceRange.Rows.Count, SourceRange.Columns.Count)
                              
            TargetRange.Value = SourceRange.Value
            wb.Saved = True
            wb.Close
            WbNamesRange(i).Offset(, -1).Value = "a"
        End If
    Next
ExitHere:
    If Err <> 0 Then
        MsgBox Err & vbLf & Err.Description
    End If
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

Sub GetXLFiles()
    Dim fso As New Scripting.FileSystemObject, oFolder As Scripting.Folder, ofile As Scripting.File
    Dim folderPath As String
    Dim LastRow As Long
    Dim WbNamesRange As Range, fCell As Range
    folderPath = Range("WBPath").Value
    If Not fso.FolderExists(folderPath) Then
        SetFolderPath
        folderPath = Range("WBPath").Value
        If fso.FolderExists(folderPath) Then
            folderPath = Range("WBPath")
        Else
            Exit Sub
        End If
    End If
    Set oFolder = fso.GetFolder(folderPath)
    LastRow = Range("B1000").End(xlUp).Row
    Set WbNamesRange = Range("B5:B1000")
    For Each ofile In oFolder.Files
        If fso.GetExtensionName(ofile.Path) Like "xls*" Then
            Set fCell = WbNamesRange.Find(ofile.Name, LookIn:=xlValues)
            If fCell Is Nothing Then
                LastRow = LastRow + 1
                Range("B" & LastRow).Value = ofile.Name
            End If
        End If
    Next
End Sub

Τάσος