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

Question

我想从一个模板工作簿和运行宏开始，以从另一个工作簿中的特定 sheet 复制一系列数据（A11:AD400 来自工作簿 2，sheet "Jan" 到 A11:AD400 工作簿 1 sheet "Jan")。除了其他 sheet 之外，每个工作簿还有 12 sheet（每月一个）。此代码应仅适用于 sheet 月份，而不适用于其他月份。我的这段代码大部分时间都有效，但经常崩溃 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

应该会好起来的

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

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

excel

vba

copy

paste