开始单元格复制数组
我有下面的代码，我用来从一张表复制一些数据到另一张，我不能为我的生活找出我可以在“OHD离开跟踪”表单上的起始单元格更改为B5。 它也是从最后一个单元格开始复制一个值，所以如果我在B26中有一些东西，然后再次运行代码，它会粘贴来自B26的新值。
我想可能是这样的：
Target.Range("B" & Lastrow2 & ":D" & Lastrow2).Resize(j) = Application.Transpose(arrData) 我已经尝试了下面不改变任何东西。
Target.Range("B6" & ":D" & Lastrow2).Resize(j) = Application.Transpose(arrData)
编辑：我需要它从B6或从下一个可用单元格开始。
完整的代码是：
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
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