Hozzászólás: [Resolved] VBA – másolás különböző mappában lévő fájlok között

Szia Péter!

Átírtam a tegnapit. A fájlneveket nem tömbben, hanem az AA1:AA15, ill. az AC1:AC15 tartományba viszem be. A bevitel után rendezem a neveket ABC szerint. Ezt egy makrórögzítéssel létrehozott Rendezes makróval végeztetem, amit testre szabtam, és a Masolas makróból hívok meg, átadva a szükséges változók értékeit.
Ezután a két tartományban lévő fájlokat nyitom meg páronként, és végzem el a lapok másolását.

Sub Masolasok()
    Dim utvonal As String, FN As String, sorszam As Integer
    Dim WB As Workbook, lapnev As String, ter As Range, kulcs As String
    Dim WBE As Workbook
    
    Application.ScreenUpdating = False
    
    Set WBE = ActiveWorkbook    'aktív, makrót tartalmazó füzet
    lapnev = ActiveSheet.Name   'aktív lap
    
    'első mappa fájlnevei az AA1:AA15-be
    utvonal = "F:\első mappa\"
    FN = Dir(utvonal & "*.xlsx", vbNormal)
    Do While FN <> ""
        sorszam = sorszam + 1
        Range("AA" & sorszam) = FN
        FN = Dir()
    Loop
    
    Set ter = Range("AA1:AA15")
    kulcs = "AA1"
    Rendezes lapnev, ter, kulcs
    

    'második mappa fájlnevei az AC1:AC15-be
    utvonal = "F:\második mappa\": sorszam = 0
    FN = Dir(utvonal & "*.xlsx", vbNormal)
    Do While FN <> ""
        sorszam = sorszam + 1
        Range("AC" & sorszam) = FN
        FN = Dir()
    Loop
    
    Set ter = Range("AC1:AC15")
    kulcs = "AC1"
    Rendezes lapnev, ter, kulcs
    
    'másolások
    For sorszam = 1 To 15
        Workbooks.Open "F:\első mappa\" & Range("AA" & sorszam)
        Set WB = ActiveWorkbook
        Workbooks.Open "F:\második mappa\" & WBE.Sheets(lapnev).Range("AC" & sorszam)
        Sheets(4).Copy After:=WB.Sheets(3)
        ActiveWorkbook.Save
        ActiveWorkbook.Close
        ActiveWorkbook.Close
    Next
    
    Application.ScreenUpdating = True
    MsgBox "Kész a másolás", vbInformation
End Sub

Sub Rendezes(lapnev, ter, kulcs)
    ActiveWorkbook.Worksheets(lapnev).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(lapnev).Sort.SortFields.Add Key:=Range(kulcs), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets(lapnev).Sort
        .SetRange ter
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub