Question

我目前有一个数组，我使用宏填充并粘贴在名为“T1”的工作表中。我当前的宏使用rowcount函数来确定使用的行，并从下一个可用行中粘贴数组。

我遇到的问题是，当我多次粘贴此数组时，数组需要间隔一行，以便我可以区分不同的提交。这是我到目前为止所做的，我希望有人可以帮助我：

Sub CopyData()

     Dim Truearray() As String
     Dim cell As Excel.Range
     Dim RowCount1 As Integer
     Dim i As Integer
     Dim ii As Integer
     Dim col As Range
     Dim col2 As Range
     i = 0
     ii = 2

     RowCount1 = DHRSheet.UsedRange.Rows.Count
     Set col = DHRSheet.Range("I1:I" & RowCount1)

     For Each cell In col

         If cell.Value = "True" Then

             Dim ValueCell As Range
             Set ValueCell = Cells(cell.Row, 3)
             ReDim Preserve Truearray(i)
             Truearray(i) = ValueCell.Value

             Dim siblingCell As Range
             Set siblingCell = Cells(cell.Row, 2)
             Dim Siblingarray() As String

             ReDim Preserve Siblingarray(i)
             Siblingarray(i) = DHRSheet.Name & "$" & siblingCell.Value

             i = i + 1

         End If

     Next

     Dim RowCount2 As Integer

     RowCount2 = DataSheet.UsedRange.Rows.Count + 1

     For ii = 2 To UBound(Truearray)
         DataSheet.Cells(RowCount2 + ii, 2).Value = Truearray(ii)
     Next

     For ii = 2 To UBound(Siblingarray)
         DataSheet.Cells(RowCount2 + ii, 1).Value = Siblingarray(ii)
     Next

     DataSheet.Columns("A:B").AutoFit

     MsgBox ("Data entered has been successfully validated & logged")

 End Sub

Answer 1

如果从底部单元格偏移两行，则会留下一行空白分隔。您还应该考虑将整个数组填充为基数1并一次性将其写入DataSheet。

Sub CopyData2()

    Dim rCell As Range
    Dim aTrues() As Variant
    Dim rRng As Range
    Dim lCnt As Long

    'Define the range to search
    With DHRSheet
        Set rRng = .Range(.Cells(1, 9), .Cells(.Rows.Count, 9).End(xlUp))
    End With

    'resize array to hold all the 'trues'
    ReDim aTrues(1 To Application.WorksheetFunction.CountIf(rRng, "True"), 1 To 2)

    For Each rCell In rRng.Cells
        If rCell.Value = "True" Then
            lCnt = lCnt + 1
            'store the string from column 2
            aTrues(lCnt, 1) = DHRSheet.Name & "$" & rCell.Offset(0, -7).Value
            'store the value from column 3
            aTrues(lCnt, 2) = rCell.Offset(0, -6).Value
        End If
    Next rCell

    'offset 2 from the bottom row to leave a row of separation
    With DataSheet.Cells(DataSheet.Rows.Count, 1).End(xlUp).Offset(2, 0)
        'write the stored information at one time
        .Resize(UBound(aTrues, 1), UBound(aTrues, 2)).Value = aTrues
    End With

End Sub

如何在粘贴数组之前插入一行

1 个答案: