将数据从多个工作表复制到多个工作簿

Question

I am attempting to copy data from multiple worksheets in an excel file to multiple files that have a template in them. So one excel file has 1500 worksheets with unique names and there exist 1500 excel files with the same name as the worksheets. I am trying to copy data (typically A1:A50) from each worksheet to another file of the same name. The target excel file has two worksheets in it and this data needs to go into each one: cells B5:B55 in "Inside Page", and cells C5:C55 in "Back Page."

Any help would be much appreciated!

Lalitha

Answer 1

This should get you started. The only issue may be performance if you have 1500 (!) worksheets.

Option Explicit
Public Sub splitsheets()
    Dim srcwb As Workbook, trgwb As Workbook
    Dim ws As Worksheet, t1ws As Worksheet, t2ws As Worksheet
    Dim rng1 As Range, rng2 As Range
    Dim trgnm As String
    Dim fpath As String

    Application.ScreenUpdating = False
'--> Set this to the location of the target workbooks
    fpath = "H:/copytest/"

    Set srcwb = ThisWorkbook
    For Each ws In srcwb.Worksheets
        trgnm = ws.Name
'--> Change A1:B3 to the range to be copied to inside page
        Set rng1 = srcwb.Sheets(trgnm).Range("A1:B3")
'--> Change C4:D5 to the range to be copied to outside page
        Set rng2 = srcwb.Sheets(trgnm).Range("C4:D5")

        Set trgwb = Workbooks.Open(fpath & trgnm & ".xls")
        With trgwb
            Set t1ws = .Sheets("Inside Page")
            Set t2ws = .Sheets("Outside Page")
        End With
'--> Change A1:B3 to the range where you want to paste
        rng1.Copy t1ws.Range("A1:B3")
'--> Change C4:D5 to the range where you want to paste
        rng2.Copy t2ws.Range("C4:D5")
        trgwb.Close True
    Next
    Application.ScreenUpdating = True
End Sub