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

VBA新手和我自己学习。 下面的代码的意图是从工作簿中的每个工作表中复制单元格“D5”，然后将所有数据粘贴到工作簿“数据”中，范围D4：D300（范围相当广泛，因此比单元格复制的单元格更多）。 问题是下面的代码不工作。 所有的代码都是在第一张表格上显示的范围（D4：D300）。 基本上复制相同的值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 

Answer 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 

Answer 2

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

 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 

Answer 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工作表