Kopieren bestimmter Zeilen von einer Arbeitsmappe in eine andere

Question

Ich habe Probleme beim Kopieren bestimmter Zeilen mit VBA.

Hier mein Code:

Dim color1 As Integer 
Dim color2 As Integer 
Dim lines As Integer 

Workbooks.Open Filename:="D:\01 January.xlsm", _ 
    UpdateLinks:=0 
lines = WorksheetFunction.CountA(Range("U:U")) - 1 


Dim i As Integer 
For i = 6 To lines + 6 

color1 = Cells(i, 21).Value 
color2 = Cells(i, 22).Value 

    If IsNumeric(Cells(i, 21)) Then 

     Select Case color1 & color2 
      Case Evaluate("=White") & Evaluate("=Blue") 
       Rows(i & ":" & i).Select 

      Case Evaluate("=Yellow") & Evaluate("=Yellow") 
       Rows(i & ":" & i).Select 

      Case Evaluate("=Yellow") & Evaluate("=Green") 
       Rows(i & ":" & i).Select 

     End Select 

    End If 
Next i 

    Selection.Copy 

    Windows("Test.xlsm").Activate 

    Rows("11:11").Select 

    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ 
     SkipBlanks:=False, Transpose:=False 
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ 
     SkipBlanks:=False, Transpose:=False 

End Sub 

So wie Sie vielleicht sehen, ich versuche, um Zeilen auszuwählen, die die Kriterien in der January.xlsm erfüllen und fügen Sie sie anschließend in das test.xlsm

Im Moment wird nur die letzte ausgewählte Zeile eingefügt und nicht alle.

Ich bin ziemlich neu zu VBA, also würde ich wirklich Ihre Hilfe hier brauchen. Ich habe mir gedacht, alle benötigten Zeilen in ein Array zu schreiben und dann in die andere Arbeitsmappe zu kopieren. Aber keine Ahnung ob das gut ist oder einfach nur ruiniert und ob das funktionieren würde, kann ich keine Lösung finden ...

Danke für all deine Hilfe!

Answer 1

Der Grund, warum nur die letzte Zeile eingefügt wird, liegt darin, dass Sie die einzelnen Zeilen durchgehen, aber nichts damit tun. Siehe geänderten Code. Ich habe die redundanten Auswahlen in der case-Anweisung entfernt und eine Bereichs/Vereinigungs-Kombination bereitgestellt, um Ihren benutzerdefinierten Bereich zu erstellen, um sicherzustellen, dass Sie nur einmal in das Arbeitsblatt einfügen.

Dim color1 As Integer 
Dim color2 As Integer 
Dim lines As Integer 

Workbooks.Open Filename:="D:\01 January.xlsm", _ 
    UpdateLinks:=0 
lines = WorksheetFunction.CountA(Range("U:U")) - 1 


Dim i As Integer 
Dim rngUnion As Range 
Dim booCopy As Boolean 
For i = 6 To lines + 6 
    booCopy = True 
    color1 = Cells(i, 21).Value 
    color2 = Cells(i, 22).Value 

    If IsNumeric(Cells(i, 21)) Then 

     Select Case color1 & color2 
      Case Evaluate("=White") & Evaluate("=Blue") 
      Case Evaluate("=Yellow") & Evaluate("=Yellow") 
      Case Evaluate("=Yellow") & Evaluate("=Green") 
      Case Else 
       booCopy = False 
     End Select 

    End If 
    If booCopy = True Then 
     If rngUnion Is Nothing Then 
      Set rngUnion = Rows(i & ":" & i) 
     Else 
      Set rngUnion = Union(rngUnion, Rows(i & ":" & i)) 
     End If 
    End If 

Next i 
If Not rngUnion Is Nothing Then 
    rngUnion.Copy 
    Windows("Test.xlsm").Activate 
    With Rows("11:11") 
     .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ 
      SkipBlanks:=False, Transpose:=False 
     .PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ 
      SkipBlanks:=False, Transpose:=False 
    End With 
    Application.CutCopyMode = False 
End If 
End Sub 

Answer 2

Der Grund, warum nur die zuletzt ausgewählte Zeile eingefügt wird, liegt daran, dass Sie nicht innerhalb der Schleife kopieren und einfügen. Wenn Sie die Selection.Copy/Paste innerhalb der Schleife verschieben, sollte der Code funktionieren. Ein besserer Weg, dies zu tun, wäre, das Kopieren und Einfügen vollständig zu vermeiden und die Werte der Zeilen direkt zu setzen. Siehe Code unten:

Dim i As Integer 
For i = 6 To lines + 6 

color1 = Cells(i, 21).Value 
color2 = Cells(i, 22).Value 

    If IsNumeric(Cells(i, 21)) Then 

     Select Case color1 & color2 
      Case Evaluate("=White") & Evaluate("=Blue"): 
       Workbooks("Test").Sheets("Sheet1").Rows(i).Value = _ 
        Workbooks("01 January").Sheets("Sheet1").Rows(i).Value 
      ... 
    End Select 

End If 
Next i 

Sie nur die Folie oder Arbeitsmappe Namen nach Bedarf aktualisieren kann, aber diese Methode ist wesentlich schneller als das Kopieren und Einfügen.

Answer 3

sollten Sie haben eine große Anzahl der Zeilen kopiert werden, und fügen Sie es sicherer ist nicht weder auf Union() noch Address() Methoden zu verlassen und wechseln Sie zu einem „Helfer“ Spalte, wo zuerst die Zeile für das Kopieren zu markieren und kopieren und in einem Schuss einfügen. Dies ist auch viel schneller als die beiden Methoden oben

Sie auch die Vorteile der SpecialCells() Methode nehmen können "numerisch" Zellen nur zu filtern:

Dim lines As Long 
Dim cell As Range 

Workbooks.Open Filename:="D:\01 January.xlsm", UpdateLinks:=0 
lines = WorksheetFunction.CountA(Range("U:U")) - 1 
With Range(Cells(6, "U"), Cells(lines + 6, "U")) '<--| reference your relevant range in column "U" 
    For Each cell In .SpecialCells(xlCellTypeConstants, xlNumbers) '<--| loop through "numeric" cells only 
     Select Case cell.Value & cell.Offset(, 1).Value 
      Case Evaluate("=White") & Evaluate("=Blue"), Evaluate("=Yellow") & Evaluate("=Yellow"), Evaluate("=Yellow") & Evaluate("=Green") 
       cell.Offset(, 2).Value = 1 '<--| mark row for copying&pasting 
     End Select 
    Next 
    With .Offset(, 2) '<-- consider column "W" cells corresponding to referenced cells 
     If WorksheetFunction.CountA(.Cells) > 0 Then '<--| if there's at least one row marked for copy&paste 
      .SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow.Copy '<--| copy all marked rows 
      With Workbooks("Test.xlsm").ActiveSheet.Rows("11:11") '<--| reference target range 
       .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ 
           SkipBlanks:=False, Transpose:=False 
       .PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ 
           SkipBlanks:=False, Transpose:=False 
      End With 
      Application.CutCopyMode = False '<--| clear clipboard 
     End If 
     .ClearContents '<--| clear "helper" column 
    End With 
End With