Question

我有工作表1 2 3 4，并且都包含相同的列集（书中还有其他选项卡，具有不同的列集）。我需要将所有选项卡数据复制到一张名为“草稿”的工作簿中已经存在的工作表中。

我找到了这段代码并尝试过：

Sub CopyFromWorksheets() 
    Dim wrk As Workbook 
'Workbook object - Always good to work with object variables

    Dim sht As Worksheet 
'Object for handling worksheets in loop

    Dim trg As Worksheet 
'Master Worksheet

    Dim rng As Range 
'Range object

    Dim colCount As Integer 
'Column count in tables in the worksheets


    Set wrk = ActiveWorkbook 
'Working in active workbook


    For Each sht In wrk.Worksheets 
        If sht.Name = "Master" Then 
            MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _ 
            "Please remove or rename this worksheet since 'Master' would be" & _ 
            "the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error" 
            Exit Sub 
        End If 
    Next sht 


'We don't want screen updating

    Application.ScreenUpdating = False 


'Add new worksheet as the last worksheet

    Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count)) 

'Rename the new worksheet

    trg.Name = "Master" 

'Get column headers from the first worksheet


'Column count first

    Set sht = wrk.Worksheets(1) 
    colCount = sht.Cells(1, 255).End(xlToLeft).Column 

'Now retrieve headers, no copy&paste needed

    With trg.Cells(1, 1).Resize(1, colCount) 
        .Value = sht.Cells(1, 1).Resize(1, colCount).Value 

'Set font as bold

        .Font.Bold = True 
    End With 


'We can start loop

    For Each sht In wrk.Worksheets 

'If worksheet in loop is the last one, stop execution (it is Master worksheet)

        If sht.Index = wrk.Worksheets.Count Then 
            Exit For 
        End If 

'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets

        Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount)) 

'Put data into the Master worksheet

        trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value 
    Next sht 

'Fit the columns in Master worksheet

    trg.Columns.AutoFit 


'Screen updating should be activated

    Application.ScreenUpdating = True 
End Sub

可以正常工作，但是创建新的选项卡并从所有选项卡复制数据，而与所需的选项卡无关。

可以正常工作，但是可以创建新的标签并从所有标签复制数据，而与所需标签无关。

Answer 1

未经任何测试，并且如果我正确理解您要实现的目标（将工作表1,2,3,4复制到草稿表），请参阅修改后的代码（从工作代码中）：

Sub CopyFromWorksheets() 
    Dim wrk As Workbook 
'Workbook object - Always good to work with object variables

    Dim sht As Worksheet 
'Object for handling worksheets in loop

    Dim trg As Worksheet 
'Master Worksheet

    Dim rng As Range 
'Range object

    Dim colCount As Integer 
'Column count in tables in the worksheets


    Set wrk = ActiveWorkbook 
'Working in active workbook


'We don't want screen updating

    Application.ScreenUpdating = False 


'Add new worksheet as the last worksheet

    Set trg = wrk.Worksheets("Draft")

'Get column headers from the first worksheet


'Column count first

    Set sht = wrk.Worksheets(1) 
    colCount = sht.Cells(1, 255).End(xlToLeft).Column 

'Now retrieve headers, no copy&paste needed

    With trg.Cells(1, 1).Resize(1, colCount) 
        .Value = sht.Cells(1, 1).Resize(1, colCount).Value 

'Set font as bold

        .Font.Bold = True 
    End With 


'We can start loop

    For Each sht In wrk.Worksheets 

'If worksheet in loop is the last one, stop execution (it is Master worksheet)

        If sht.Name = "Sheet1" or sht.Name = "Sheet2" or sht.Name = "Sheet3" or sht.Name = "Sheet4" Then

'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets

            Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount)) 

'Put data into the Master worksheet

            trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value 
        End If 
    Next sht 

'Fit the columns in Master worksheet

    trg.Columns.AutoFit 


'Screen updating should be activated

    Application.ScreenUpdating = True 
End Sub

从特定工作表复制数据并保存在现有工作表“草稿”中

1 个答案: