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

Míg Imre előkerül, és megmondja, miért nem jó ez:

Sub Masolasok()
    Dim tomb(2, 15), utvonal As String, FN As String, sorszam As Integer
    Dim WB As Workbook
    
    'első mappa fájlnevek feltöltése a tomb() tömbbe
    utvonal = "F:\első mappa\"
    FN = Dir(utvonal & "*.xlsx", vbNormal)
    Do While FN <> ""
        sorszam = sorszam + 1
        tomb(1, sorszam) = FN
        FN = Dir()
    Loop
    
    'második mappa fájlnevek feltöltése a tomb() tömbbe
    utvonal = "F:\második mappa\": sorszam = 0
    FN = Dir(utvonal & "*.xlsx", vbNormal)
    Do While FN <> ""
        sorszam = sorszam + 1
        tomb(2, sorszam) = FN
        FN = Dir()
    Loop
    
    'másolások
    For sorszam = 1 To 15
        Workbooks.Open "F:\első mappa\" & tomb(1, sorszam)
        Set WB = ActiveWorkbook
        Workbooks.Open "F:\második mappa\" & tomb(2, sorszam)
        Sheets(4).Copy After:=WB.Sheets(3)
        ActiveWorkbook.Save
        ActiveWorkbook.Close
        ActiveWorkbook.Close
    Next
End Sub

Esetleg ott lehet majd gond, hogy nem biztos, hogy az 1. mappa 1. fájljához kell a 2. mappa 1. fájl utolsó lapja. Lehet, hogy valami szerint (név, mentési idő) párba kell rendezni a fájlokat a másolások elindítása előtt.
Az utvonal változók értékét írd át a saját 2 útvonaladra, minden előfordulásukkor a makró futtatása előtt.

• A hozzászólás módosításra került: 7 years telt el-delila.

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

Részemről szívesen. 🙂