VBA: Zelle aus allen Arbeitsblättern kopieren und in Spalte einfügen

Question

Neu in VBA und selbstständig lernen. Die Absicht für den folgenden Code ist, Zelle "D5" von jedem Blatt in der Arbeitsmappe zu kopieren und dann alle Daten in Arbeitsmappe "Data", Bereich D4: D300 (der Bereich ist ziemlich breit, so dass mehr Zelle verfügbar als Zellen haben kopiert). Das Problem ist, dass der folgende Code nicht funktioniert. Der gesamte Code besteht darin, Zelle D5 von dem ersten Blatt über den angegebenen Bereich hinweg zu bewältigen (D4: D300). Grundsätzlich den gleichen Wert 266 mal kopieren. Jede Hilfe wird sehr geschätzt. Wenn es eine elegantere/effizientere Möglichkeit gibt, diesen Code zu schreiben, geben Sie dies bitte an.

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

Sie brauchen nicht ein Ende Bereich angeben - nur ‚count‘ die Anzahl der Blätter, die Gesamtanzahl der Werte bestimmen Sie auf die Registerkarte data hinzuzufügen benötigen. Außerdem wurde eine Überprüfung hinzugefügt, um festzustellen, ob Sie sich auf dem Arbeitsblatt Data befinden, sodass Sie den Wert D5 von Data nicht erneut in eine Zeile desselben Arbeitsblatts kopieren.

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

bei jedem Durchlauf durch Ihre ActiveWorkbook.Worksheets Schleife, in die Zelle einzufügen D unter der letzten Zelle in der Spalte, es sei denn D4 leer ist, in welchem ​​Fall Paste in D4. Ich gehe davon aus, Spalte D ist komplett leer, bevor Sie das Makro ausführen, aber wenn D3 etwas in sich hat, können Sie den .Range("D4") = "" Test beseitigen.

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

, wenn Sie sich mehr um Werte sind, dann ist ein prägnanter Code könnte die folgende sein:

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 

, wo Sie zuerst speichern alle Blätter D5 Zellenwerte in ein Feld und schreiben sie dann in einem Schuss in Data Arbeitsblatt