Question

我想从模板工作簿开始并运行宏来从另一个工作簿中的特定工作表复制一系列数据（A11：AD400从工作簿2，工作表“Jan”到A11：AD400工作簿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

应该会变得更好

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

1 个答案: