VBA：複製所有工作表中的單元格並粘貼到列中

Question

VBA中的新功能和自行學習。 以下代碼的目的是從工作簿中的每張工作表中複製單元格「D5」，然後將所有數據粘貼到工作簿「數據」中，範圍D4：D300（範圍相當廣泛，因此它將具有比單元格更多的單元格複製）。問題是下面的代碼不起作用。所有的代碼正在執行的是從第一個表單上的D5單元格（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工作表上，因此您不會將D5的值再次從Data複製到同一工作表中的一行中。

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列在運行宏之前是完全空白的，但是如果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 

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