簡體   English   中英

復制並粘貼 excel 表,要在代碼中引用的表單元格數據的值

[英]Copy and Paste a excel sheet , Value of Sheet Cell Data to be referenced in code

我正在嘗試將工作表復制並粘貼到新工作簿中,新工作簿中不會有任何 vba 所以我正在創建一個工作簿,然后創建一個工作表並將復制的數據粘貼到該工作表中。 為此,我必須引用從中復制數據的工作表。

從中復制數據的工作表將不斷變化。 因此,我引用要在 Sheet1 單元格 B1 中復制的工作表。 此外,目標工作表(新工作簿和工作表)的名稱也會不斷變化,這些是從原始工作表的 Sheet1 單元格 B2、C2 分配的。 這一切工作正常,

在此處輸入圖像描述

有關更多信息,請參閱底部的 MR Excel 帖子。

我堅持的唯一部分如下所述,不能再進一步 go 了。 這是我的代碼。 我在原始代碼中留下了哪些工作,這被注釋掉了。 在我的一些嘗試中,我也離開了。

Object 不支持此屬性或方法

wksh(CopySheet).UsedRange.Copy 'COPY THIS SHEET

這是代碼

''Copy and Paste Sheet
        Application.SheetsInNewWorkbook = 1 'Number of Sheets in New Workbook
        Workbooks.Add 'Add sheet to new workbook
        With ThisWorkbook ' Now with this workbook

'' ########## Refering to WORKBOOK + SHEET from which the data is to be copied From to new Sheet ########        
Dim wkb As Excel.Workbook
Dim wksh As Excel.Worksheet
Dim CopySheet As Variant

    Set wkb = Excel.Workbooks("Test Copy Sheet3B.xlsm") ' USE THIS WORKBOOK
    Set wksh = wkb.Worksheets("Sheet1") 'USE THIS SHEET

    wksh.Range("B1") = CopySheet 'COPY THE SHEET NAMED IN THIS CELL E.G Sheet10
    wksh(CopySheet).UsedRange.Copy 'COPY THIS SHEET
    'wksh.Range("B1").UsedRange.Copy
    'wks.Sheets(Sheets("Sheet1").Range("B1").Value).Copy
    'ActiveWorkbook.Sheets(1).Range("A1").PasteSpecial xlPasteValues = CopySheet
     ActiveWorkbook.Sheets(1).Range("A1").PasteSpecial xlPasteValues 'PASTE IN NEW CREATED WORKBOOK SHEET
     
'' ############### Original Code ###############
''Copy and Paste Sheet
'   Application.SheetsInNewWorkbook = 1
'        Workbooks.Add
'    With ThisWorkbook
'        .Sheets("Sheet2").UsedRange.Copy 'Copy this sheet
'        ActiveWorkbook.Sheets(1).Range("A1").PasteSpecial xlPasteValues
'        ActiveWorkbook.Sheets(1).Name = "Data Search" ' new sheet name     
'' ############### Original Code ###############

我還在 Excel 先生上發布了這個, 這里有一個可下載的工作簿和完整代碼,因為我已經解決了大部分問題,最后幾篇帖子最好在 Excel 先生的第 2 頁上。 這是我堅持的最后一點。

答案在下面,非常感謝 Luuk 為我指明了正確的方向。

修復

''Copy and Paste Sheet
        Application.SheetsInNewWorkbook = 1
        Workbooks.Add
        With ThisWorkbook
        
Dim wkb As Excel.Workbook
Dim wksh As Excel.Worksheet
Dim CopySheet As Variant

    Set wkb = Excel.Workbooks("Test Copy Sheet3B.xlsm") ' USE THIS WORKBOOK
    Set wksh = wkb.Worksheets("Sheet1") 'USE THIS SHEET
    CopySheet = wksh.Range("B1")
    .Sheets(CopySheet).UsedRange.Copy
    ActiveWorkbook.Sheets(1).Range("A1").PasteSpecial xlPasteValues 'PASTE IN NEW CREATED WORKBOOK SHEET

完整代碼,也發布在 Excel 先生上,鏈接見上面的帖子

Private Sub CommandButton3_Click()

Application.ScreenUpdating = False
If Sheets(Sheets("Sheet1").Range("B1").Value).Range("A2").Value = "" Then
'ExportError.Show
MsgBox "Nothing to report"
Else
''Copy and Paste Sheet
        Application.SheetsInNewWorkbook = 1
        Workbooks.Add
        With ThisWorkbook
'' ########## Refering to WORKBOOK + SHEET from which the data is to be copied From to new Sheet ########
Dim wkb As Excel.Workbook
Dim wksh As Excel.Worksheet
Dim CopySheet As Variant

    Set wkb = Excel.Workbooks("Test Copy Sheet3B.xlsm") ' USE THIS WORKBOOK, name must match
    Set wksh = wkb.Worksheets("Sheet1") 'USE THIS SHEET name must match
    CopySheet = wksh.Range("B1")
    .Sheets(CopySheet).UsedRange.Copy
    ActiveWorkbook.Sheets(1).Range("A1").PasteSpecial xlPasteValues 'PASTE IN NEW CREATED WORKBOOK SHEET
     
'' Rename Tab On new Sheet
    Dim TabName As Variant
        TabName = ThisWorkbook.Worksheets("Sheet1").Range("B2").Value
    ActiveWorkbook.Sheets(1).Name = TabName
''##################
 '' Format Header in new workbook
        ActiveWorkbook.Sheets(1).Columns("A:g").ColumnWidth = 25
        ActiveWorkbook.Sheets(1).Range("A1:g1").Font.Name = "Calibri"
        ActiveWorkbook.Sheets(1).Range("A1:g1").HorizontalAlignment = xlCenter
        ActiveWorkbook.Sheets(1).Range("A1:g1").Font.Color = vbWhite
        ActiveWorkbook.Sheets(1).Range("A1:g1").Interior.ColorIndex = 16 'Color Grey
' Create a Freeze panel on new sheet
   Dim wks As Worksheet
        For Each wks In Worksheets
            wks.Activate
                With Application.ActiveWindow
                .SplitColumn = 0
            .SplitRow = 1
        End With
        Application.ActiveWindow.FreezePanes = True
            If Not ActiveSheet.AutoFilterMode Then
                ActiveSheet.Range("A1").AutoFilter
            End If
        Next wks
'Fill all BLANK CELLS with Hyphen
    Dim r As Range, LastRow As Long
        LastRow = Cells(Rows.Count, "A").End(xlUp).Row
        For Each r In ActiveWorkbook.Sheets(1).Range("A1:g" & LastRow)
        If r.Text = "" Then r.Value = "-"
    Next r
'Rename Sheet
    Dim SheetName As Variant
   '   Application.DisplayAlerts = False
        SheetName = ThisWorkbook.Worksheets("Sheet1").Range("B3").Value
 'Save Sheet
    ActiveWorkbook.SaveAs Filename:=(SheetName) & Format(Now, " dd_mm_yyyy    HH_mm_ss") & ".xlsx", FileFormat:=51

   Application.ScreenUpdating = True
End With
End If
End Sub

暫無
暫無

聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.

 
粵ICP備18138465號  © 2020-2024 STACKOOM.COM