Question

我有以下代码，我用它来将一些数据从一张纸复制到另一张，我不能在我的生活中弄清楚我可以在哪里将起始单元格更改为B5 ＆＃34; OHD离开跟踪器＆＃34;片。它也从最后一个单元格开始复制一个值，所以如果我在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

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

用于复制数组的起始单元格

1 个答案: