将一个工作簿中的工作表中的范围复制到另一个工作簿中的工作表中

Question

我想从模板工作簿开始并运行宏以复制另一个工作簿中特定工作表中的一系列数据（工作簿 2 中的 A11:AD400，工作表“Jan”到 A11:AD400 Workbook 1 工作表“Jan” ）。除了其他工作表外，每个工作簿都有 12 个工作表（每月一个）。此代码应仅适用于月表而不适用于其他任何内容。我有这段代码大部分时间都可以工作，但 Excel 经常崩溃。我觉得有一种更有效的方法来完成任务。任何帮助表示赞赏。

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

Answer 1

我会使用删除 Selectcase 函数

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

并在巩固改变这部分

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

与

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

应该会好起来的