VBA：从所有工作表中复制单元格并粘贴到列中答案

【问题标题】：VBA: Copy cell from all worksheets and paste into columnVBA：从所有工作表中复制单元格并粘贴到列中
【发布时间】：2017-03-16 21:43:23
【问题描述】：

VBA 新手，自学。下面代码的目的是从工作簿中的每个工作表中复制单元格“D5”，然后将所有数据粘贴到工作簿“数据”中，范围为 D4:D300（范围非常广泛，因此可用的单元格比复制的单元格多）。问题是下面的代码不起作用。代码所做的所有事情都是在指示的范围内（D4:D300）处理第一张纸上的单元格 D5。基本上复制相同的值 266 次。非常感谢任何帮助。如果有更优雅/更有效的方式来编写此代码，请告知。

Sub copycell()

    Dim sh As Worksheet
    Dim wb As Workbook
    Dim DestSh As Worksheet
    Dim LastRow As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set wb = ThisWorkbook
    Set DestSh = wb.Sheets("Data")

    ' Loop through worksheets that start with the name "20"

    For Each sh In ActiveWorkbook.Worksheets

                ' Specify the range to copy the data

        sh.Range("D5").Copy


        ' Paste copied range into "Data" worksheet in Column D

        With DestSh.Range("D4:D300")
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
        End With


    Next

End Sub

【问题讨论】：

标签： vba excel

【解决方案1】：

您不需要指定结束范围 - 只需“计算”页数以确定您需要添加到 data 选项卡的值的总数。还添加了检查以查看您是否在 Data 工作表上，这样您就不会再次将 Data 中的 D5 值复制到同一工作表中的一行中。

Sub copycell()

    Dim sh As Worksheet
    Dim wb As Workbook
    Dim DestSh As Worksheet
    Dim i As Integer

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set wb = ThisWorkbook
    Set DestSh = wb.Sheets("Data")

    ' Loop through worksheets that start with the name "20"
    i = 4
    For Each sh In ActiveWorkbook.Worksheets
    If sh.Name = "Data" Then Exit Sub
        sh.Range("D5").Copy
        With DestSh.Range("d" & i)
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
        End With
    i = i + 1

    Next

End Sub

【讨论】：

【解决方案2】：

在每次通过ActiveWorkbook.Worksheets 循环时，粘贴到 D 列最后一个单元格下方的单元格中，除非 D4 为空白，在这种情况下粘贴到 D4 中。我假设在运行宏之前 D 列是完全空白的，但如果 D3 中有一些东西，你可以取消 .Range("D4") = "" 测试。

Sub copycell()
Dim sh As Worksheet
Dim wb As Workbook
Dim DestSh As Worksheet
Dim LastRow As Long

    On Error GoTo GracefulExit:
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set wb = ThisWorkbook
    Set DestSh = wb.Sheets("Data")
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> "Data" Then
            sh.Range("D5").Copy
            ' Paste copied range into "Data" worksheet in Column D
            ' starting at D4
            With DestSh
                If .Range("D4") = "" Then
                    With .Range("D4")
                        .PasteSpecial xlPasteValues
                        .PasteSpecial xlPasteFormats
                    End With
                Else
                    With .Cells(.Cells(.Rows.Count, 4).End(xlUp).Row + 1, 4)
                        .PasteSpecial xlPasteValues
                        .PasteSpecial xlPasteFormats
                    End With
                End If
            End With
        End If
        Application.CutCopyMode = False
    Next
GracefulExit:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    If Err <> 0 Then
        MsgBox "An unexpected error no. " & Err & ": " _
        & Err.Description & " occured!", vbExclamation
    End If
End Sub

【讨论】：

【解决方案3】：

如果您更关心值，那么更简洁的代码可能如下：

Option Explicit

Sub copycell()
    Dim sh As Worksheet
    Dim iSh As Long

    With ThisWorkbook
        ReDim dataArr(1 To .Worksheets.Count - 1)
        For Each sh In .Worksheets
            If sh.Name <> "Data" Then
                iSh = iSh + 1
                dataArr(iSh) = sh.Range("D5").Value
            End If
        Next
        .Worksheets("Data").Range("D4").Resize(.Worksheets.Count - 1).Value = Application.Transpose(dataArr)
    End With
End Sub

您首先将所有工作表 D5 单元格值存储到一个数组中，然后将它们一次性写入Data 工作表

【讨论】：