Solved: Copy information in named range to another workbook

[bryVA]

Hello all,

I need to get an open sheet to extract information from multiple excel files so I have the following code that does this. However this takes a long time for it to pull over so I was wondering if there is a more efficient way to write this code.


Workbooks.Open Filename:="C://CAREA2.xls"

Worksheets("Database1").Activate
Range("CallData").Select
Selection.Copy

ActiveWorkbook.Close False

Worksheets("Database1").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
'CAREA Staff Database Merge
Workbooks.Open Filename:="C://CAREA2.xls"

Worksheets("StaffData").Activate
Range("StaffData").Select
Selection.Copy

ActiveWorkbook.Close False

Worksheets("StaffData").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
'EAREA Database Merge
Workbooks.Open Filename:="C://EAREA2.xls"

Worksheets("Database1").Activate
Range("CallData").Select
Selection.Copy

ActiveWorkbook.Close False

Worksheets("Database1").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
'EAREA Staffing Data Merge
Workbooks.Open Filename:="C://EAREA2.xls"

Worksheets("StaffData").Activate
Range("StaffData").Select
Selection.Copy

ActiveWorkbook.Close False

Worksheets("Staffdata").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
'SAREA Call Database Merge
Workbooks.Open Filename:="C://SAREA2.xls"

Worksheets("Database1").Activate
Range("CallData").Select
Selection.Copy

ActiveWorkbook.Close False

Worksheets("Database1").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
'SAREA Staffing Data Merge
Workbooks.Open Filename:="C://SAREA2.xls"

Worksheets("StaffData").Activate
Range("StaffData").Select
Selection.Copy

ActiveWorkbook.Close False

Worksheets("Staffdata").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
'WAREA Database Merge
Workbooks.Open Filename:="C://WAREA2.xls"

Worksheets("Database1").Activate
Range("CallData").Select
Selection.Copy

ActiveWorkbook.Close False

Worksheets("Database1").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
'WAREA Staffing Data Merge
Workbooks.Open Filename:="C://WAREA2.xls"

Worksheets("StaffData").Activate
Range("StaffData").Select
Selection.Copy

ActiveWorkbook.Close False

Worksheets("Staffdata").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
'Blocked Call Data Merge
BlockedDataSetup

'Refocus on Worksheet(1)
Worksheets(1).Activate
Range("B3").Select


Thanks for all your help,

-B

[mdmackillop]

Try this version. I think it does the same thing!

Option Explicit

Dim Book As Workbook

Sub DoCopy()
Dim WB As Workbook
Dim arr, a
Application.ScreenUpdating = False
Set Book = ActiveWorkbook
arr = Array("CAREA", "EAREA", "SAREA", "WAREA")
For Each a In arr
Set WB = Workbooks.Open("C://" & a & ".xls")
Range("CallData").Copy Tgt("Database1")
Range("StaffData").Copy Tgt("StaffData")
WB.Close
Next
Application.ScreenUpdating = True
End Sub

Function Tgt(Sht As String) As Range
Set Tgt = Book.Sheets(Sht).Cells(Rows.Count, 1).End(xlUp)(2)
End Function

[bryVA]

Great. Thanks. That is what I was looking for. Your amazing mdmackillop. I need to learn how to write code this way.

Again thanks so much,

-B