VBA Zellen kopieren, wenn ein Wert drin

Question

Ich möchte ein Makro schreiben, die die 1 Zellen auf ein anderes Blatt kopieren, wenn sie einen Wert enthalten.

Tabelle:

Erwartung:

Bisher habe ich versucht, dies aber nur letzte Zelle von sheet1 zum ersten Zelle in Blatt 2

Sub CopyBasedonSheet1() 
    Dim i As Integer 
    Dim j As Integer 
    Sheet1LastRow = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row 
    Sheet2LastRow = Worksheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Row 

    For j = 1 To Sheet1LastRow 
     For i = 1 To Sheet2LastRow 
      If Worksheets("Sheet1").Cells(j, 2).Value = "a" Then 
       Worksheets("Sheet2").Cells(i, 1).Value = Worksheets("Sheet1").Cells(j, 1).Value 
      Else 
      End If 
     Next i 
    Next j 
End Sub 

Answer 1

Sie kopieren sollten mach es mit einer Schleife, denn wenn du eine Zeile vom ersten Blatt hast, gibt es nur einen Platz, an dem du es kopieren willst, nicht viele:

Sub CopyBasedonSheet1() 
    Dim i As Integer 
    Dim j As Integer 
    Sheet1LastRow = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row 

    i = 1 
    For j = 1 To Sheet1LastRow 
     If Worksheets("Sheet1").Cells(j, 2).Value = "a" Then 
      Worksheets("Sheet2").Cells(i, 1).Value = Worksheets("Sheet1").Cells(j, 1).Value 
      Worksheets("Sheet2").Cells(i, 2).Value = Worksheets("Sheet1").Cells(j, 2).Value 
      i = i + 1 
     End If 
    Next j 
End Sub 

Answer 2

Oder Sie können einen anderen Ansatz zusammen versuchen, die auch schneller ... ist

Sub CopyData() 
Dim ws1 As Worksheet, ws2 As Worksheet 
Dim x, y() 
Dim i As Long, j As Long 
Set ws1 = Sheets("Sheet1") 
Set ws2 = Sheets("Sheet2") 
x = ws1.Range("A1").CurrentRegion.Value 
ReDim y(1 To Application.CountIf(ws1.Columns(2), "a"), 1 To 2) 
j = 1 
For i = 1 To UBound(x, 1) 
    If x(i, 2) = "a" Then 
     y(j, 1) = x(i, 1) 
     y(j, 2) = x(i, 2) 
     j = j + 1 
    End If 
Next i 
ws2.Range("A:B").Clear 
ws2.Range("A1").Resize(UBound(y, 1), 2).Value = y 
End Sub