Copying a range from sheets in one workbook into sheets in another workbook

Question

I would like to start with a template workbook and run the macro to copy a range of data from specific sheets in another workbook (A11:AD400 from Workbook 2, sheet "Jan" to A11:AD400 Workbook 1 sheet "Jan"). Each workbook has 12 sheets (one per month) in addition to other sheets. This code should only apply to the month sheets and nothing else. I have this code that works most of the time but crashes Excel a lot. I feel there is a more efficient way to complete the task. Any help is appreciated.

Option Explicit
Option Compare Text

Dim i As Long, j As Long
Dim wB As Workbook, wBK As Worksheet
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim curSht As String

Sub MoveDataOldtoNew()

'Optimize Macro Speed
Application.ScreenUpdating = False: Application.EnableEvents = False:         Application.Calculation = xlCalculationManual
'Warning message
If MsgBox("AE VERSION - These changes cannot be undone. It is advised to save a copy before proceeding. Do you wish to proceed?", vbYesNo + vbQuestion) = vbNo Then
    Exit Sub
  End If
If MsgBox("ONLY for Version G Trackers - No other Excel sheets should be open. This can take up to one minute to complete. Continue?", vbYesNo + vbQuestion) = vbNo Then
    Exit Sub
  End If
'Retrieve Target File From User
Set FldrPicker = Application.FileDialog(msoFileDialogFilePicker)
With FldrPicker
    .Title = "Select A Previous Tracker"
    .AllowMultiSelect = False
    If .Show = -1 Then
    myFile = .SelectedItems(1)

    If myFile <> ThisWorkbook.FullName Then
      Set wB = Workbooks.Open(Filename:=myFile)

        For Each wBK In wB.Worksheets
            SelectCase
        Next wBK

      wB.Close savechanges:=False
    End If

ResetSettings:
Application.EnableEvents = True: Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic

MsgBox "Import Complete!"
End If
End With
End Sub

Sub SelectCase()

    Select Case Trim(wBK.Name)
    Case "Jan"
        Consolidate
    Case "Feb"
        Consolidate
    Case "Mar"
        Consolidate
    Case "Apr"
        Consolidate
    Case "May"
        Consolidate
    Case "Jun"
        Consolidate
    Case "Jul"
        Consolidate
    Case "Aug"
        Consolidate
    Case "Sep"
        Consolidate
    Case "Oct"
        Consolidate
    Case "Nov"
        Consolidate
    Case "Dec"
        Consolidate
    Case Else
        Debug.Print wBK.Name
    End Select

End Sub


Sub Consolidate()

Dim fM As Long, wMas As Worksheet
Set wMas = ThisWorkbook.Sheets(Trim(wBK.Name))
'wMas.Unprotect

With wMas
.Unprotect

    wBK.Range("A11:AD400").Copy
    wMas.Range("A11:AD400").PasteSpecial xlPasteValues
    Application.Goto wMas.Range("A11"), True
    Application.CutCopyMode = False
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
End With
'wMas.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True

End Sub

Personally, I feel that dim wBK As Worksheet is just plain confusing. — user4039065
Can you say what some examples of crashes are? Do you know or maybe just suspect what the cause was, or which line in your code caused the crash? — elliot svensson
@dwirony Sub SelectCase() - is my way of defining which sheets in the workbook I need to copy to and from. — Bofett

gioxc88 gioxc88 · Accepted Answer · 2018-03-20T22:58:17

I would get rid of the Selectcase function using

Dim found As Integer
Dim wsNames()
wsNames = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", _
    "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")

For Each wBK In wB.Worksheets
    On Error Resume Next
    found = WorksheetFunction.Match(Trim(wBK.Name), wsNames, 0)
    If Err.Number <> 0 Then
        Consolitate
    Else
        Err.Clear
        Debug.Print wBK.Name
    End If
    On Error GoTo 0
Next wBK

And in consolidate changing this part

wBK.Range("A11:AD400").Copy
wMas.Range("A11:AD400").PasteSpecial xlPasteValues

with

wMas.Range("A11:AD400").Value = wBK.Range("A11:AD400").Value

it should get better

Copying a range from sheets in one workbook into sheets in another workbook

1 Answers