Startzelle zum Kopieren Array

Question

Ich habe den folgenden Code, den ich verwende, um einige Daten von einem Blatt zu einem anderen zu kopieren, und ich kann nicht für das Leben von mir herausfinden, wo ich die Startzelle auf B5 ändern kann das Blatt "OHD Leave Tracker". Es startet auch die Kopie von der letzten Zelle mit einem Wert. Wenn ich also etwas in B26 habe und den Code erneut ausführe, fügt er die neuen Werte aus B26 ein.

ich denke, es in der Linie sein könnte:

Target.Range("B" & Lastrow2 & ":D" & Lastrow2).Resize(j) = Application.Transpose(arrData) 

ich versucht habe, die, unter dem sich nichts ändern.

Target.Range("B6" & ":D" & Lastrow2).Resize(j) = Application.Transpose(arrData) 

Edit: Ich brauche es entweder von B6 oder von der nächsten verfügbaren Zelle zu starten.

Der vollständige Code ist:

Sub CopyNow() 

Call ShtArr 

    Dim Start: Start = Timer 
    Dim c As Range 
    Dim j As Integer 
    Dim Source As Worksheet, Target As Worksheet 
    Dim arrData As Variant: ReDim arrData(2, 0) 
    Dim DevList As Object: Set DevList = CreateObject("System.Collections.ArrayList") 
    Dim Lastrow2 As Long 
    'Public SheetArr As String 

    'SheetArr = 

    Lastrow2 = Worksheets("OHD Leave Tracker").Range("B" & Rows.Count).End(xlUp).row 
    'Worksheets("OHD Leave Tracker").Range("B6:D" & Lastrow2).Clear 
    With Worksheets("Lists") 
     For Each c In .Range("G1", .Range("G" & Rows.Count).End(xlUp)) 
      DevList.Add c.Text 
     Next c 
    End With 

    For Each Source In Worksheets(SheetArr) 
     Set Target = ThisWorkbook.Worksheets("OHD Leave Tracker") 
     With Source 
      For Each c In .Range("F1:F100") ', .Range("F" & Rows.Count).End(xlUp)) 
       If c = "Approved" Then 
        With c.EntireRow 
         If Not DevList.Contains(.Cells(1, 2).Text) Then 
          ReDim Preserve arrData(2, j) 
          arrData(0, j) = .Cells(1, 1) 
          arrData(1, j) = .Cells(1, 2) 
          arrData(2, j) = .Cells(1, 3) 
          'Debug.Assert Trim(.Cells(1, 3)) <> "" 
          j = j + 1 
         End If 
        End With 
       End If 
      Next c 
     End With 
    Next Source 
Firstrow = ThisWorkbook.Worksheets("OHD Leave Tracker").Range("B6") 
    Target.Range("B6" & ":D" & Lastrow2).Resize(j) = Application.Transpose(arrData) 
    Debug.Print Timer - Start 

     Dim Lastrow As Long 

    Lastrow = ThisWorkbook.Worksheets("OHD Leave Tracker").Range("B" & Rows.Count).End(xlUp).row 

    Worksheets("OHD Leave Tracker").Range("A6:A" & Lastrow).Formula = "=IF(ISERROR(VLOOKUP(B6,Lists!G:G,1,FALSE)),""Delete"",""Keep"")" 

     Last = Worksheets("OHD Leave Tracker").Cells(Rows.Count, "A").End(xlUp).row 
    For i = Last To 1 Step -1 
     If Worksheets("OHD Leave Tracker").Cells(i, "A").Value = "Delete" Then 
      Worksheets("OHD Leave Tracker").Cells(i, "A").EntireRow.Delete 
     End If 
    Next i 
Call SortNow 
    ThisWorkbook.Sheets("OHD Leave Tracker").Range("N6:JE6").AutoFill Destination:=Range("N6:JE188"), Type:=xlFillDefault 
    ThisWorkbook.Sheets("OHD Leave Tracker").Range("E6:F6").AutoFill Destination:=Range("E6:F188"), Type:=xlFillDefault 

    Sheets("OHD Leave Tracker").Range("B5:D" & Lastrow).RemoveDuplicates Columns:=Array(1, 2, 3), _ 
     Header:=xlNo 
End Sub 

Answer 1

Option Explicit 

Sub CopyNow() 

    Call ShtArr 

    Dim Start: Start = Timer 
    Dim c As Range 
    Dim j As Integer 
    Dim Source As Worksheet 
    Dim arrData As Variant: ReDim arrData(2, 0) 
    Dim DevList As Object: Set DevList = CreateObject("System.Collections.ArrayList") 
    Dim LastRow As Long 
    With Worksheets("OHD Leave Tracker") 

     With Worksheets("Lists") 
      For Each c In .Range("G1", .Range("G" & .Rows.count).End(xlUp)) 
       DevList.Add c.Text 
      Next c 
     End With 

     For Each Source In Worksheets(SheetArr) 
      With Source 
       For Each c In .Range("F1:F100") ', .Range("F" & Rows.Count).End(xlUp)) 
        If c = "Approved" Then 
         With c.EntireRow 
          If Not DevList.Contains(.Cells(1, 2).Text) Then 
           ReDim Preserve arrData(2, j) 
           arrData(0, j) = .Cells(1, 1) 
           arrData(1, j) = .Cells(1, 2) 
           arrData(2, j) = .Cells(1, 3) 
           'Debug.Assert Trim(.Cells(1, 3)) <> "" 
           j = j + 1 
          End If 
         End With 
        End If 
       Next c 
      End With 
     Next Source 

     LastRow = .Range("B" & .Rows.count).End(xlUp).Row + 1 

     .Rows(LastRow).Columns("B:D").Resize(j) = Application.Transpose(arrData) 
     Debug.Print Timer - Start 

     LastRow = .Range("B" & .Rows.count).End(xlUp).Row + 1 

     .Range("A5:A" & LastRow).Formula = "=IF(ISERROR(VLOOKUP(B6,Lists!G:G,1,FALSE)),""Delete"",""Keep"")" 

     For i = LastRow To 1 Step -1 
      If .Cells(i, "A").Value = "Delete" Then 
       .Cells(i, "A").EntireRow.Delete 
      End If 
     Next i 

     Call SortNow 
     .Range("N5:JE188").AutoFill 
     .Range ("E5:F188"), Type:=xlFillDefault 

     .Range("B5:D" & LastRow).RemoveDuplicates Columns:=Array(1, 2, 3), _ 
                Header:=xlNo 
    End With 
End Sub