使用在MASTER的单元格A1上命名的工作表将单元格复制到另一个工作簿

时间:2014-06-09 22:59:09

标签: excel-vba vba excel

我有一本带有" MASTER"通过选择A1中的下拉框填充的工作表。我需要从那些" MASTER"中复制一些信息。另一本工作簿"夏季完成"其中工作表名称与下拉框对应。我写了宏,但我无法根据MASTER表的A1中的内容查看表单名称。在shtName遇到麻烦的地方。我相信如果我能够通过它没有看到工作表名称,这将有效。

Sub Copy_With_AutoFilter()

Dim My_Range As Range
Dim wsMASTER As Worksheet
Dim shtName As Worksheet
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim rng As Range
Dim wbTarget As Workbook
Dim wbSource As Workbook

'Set filter range on ActiveSheet
Set My_Range = Range("A94:E119")

'Set the sheet
Set wbSource = ThisWorkbook
Set wsMASTER = wbSource.Worksheets("MASTER")
Set shtName = wbSource.Worksheets(wsMASTER.Range("A1").Value)

'Set the destination worksheet
Set wbTarget = Workbooks.Open("A:\Accounting\Manifest Project\Manifest\2014\Completion Bonus\Summer Bonus\" & shtName & ".xlsx")

'Unprotect Sheet
If ActiveWorkbook.ProtectStructure = True Or _
    My_Range.Parent.ProtectContents = True Then
      MsgBox "Sorry, not working when the workbook or worksheet is protected", _
            vbOKOnly, "Copy to new worksheet"
      Exit Sub
End If

'Change ScreenUpdating, Calculation, EnableEvents, .....
With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False

'Firstly, remove the AutoFilter
My_Range.Parent.AutoFilterMode = False

'Filter and set the filter field and the filter criteria
My_Range.AutoFilter Field:=1, Criteria1:=">0"

'Check if there are not more then 8192 areas
CCount = 0
On Error Resume Next
CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisisble).Areas(1).cells.Count
On Error GoTo 0
If CCount = 0 Then
    MsgBox "There are more than 8192 areas:" _
         & vbNewLine & "It is not possible to copy the visible data.", _
           vbOKOnly, "Copy to worksheet"
Else
    'Copy the visible data and use PasteSpecial to paste to the Destsh
    With My_Range.Parent.AutoFilter.Range
        On Error Resume Next
        'Set rng to the visible cells in My_Range without the header row
        Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
                  .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not rng Is Nothing Then
            'Copy and paste the cells into DestSh below the existing data
            rng.Copy
            With wbTarget.Range("A" & LastRow(wbTarget) + 1)
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With
        End If
    End With
End If

'Close AutoFilter
My_Range.Parent.AutoFilterMode = False

'Restore ScreenUpdating, Calculation, EnableEvents, ....
ActiveWindow.View = ViewMode
Application.Goto wbTarget.Range("A1")
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = CalcMode
End With
End Sub

1 个答案:

答案 0 :(得分:0)

Set shtName = wbSource.Worksheets(wsMASTER.Range("A1").Value)

您的问题表明您想要的工作表位于wbTarget,而不是wbSource ...

尝试此修订:

Dim sName as String

Set wbSource = ThisWorkbook
Set wsMASTER = wbSource.Worksheets("MASTER")

Set wbTarget = Workbooks.Open("A:\Accounting\Manifest Project\Manifest\2014\" & _
                          "Completion Bonus\Summer Bonus\Completion Bonus.xlsx")

sName = wsMASTER.Range("A1").Value

On Error Resume Next
Set shtName = wbTarget.Worksheets(sName)
On Error Goto 0

If shtName is Nothing Then
    Msgbox "Sheet '" & sName "' was not found in target workbook!"
    Exit Sub
End If

'rest of code using shtName