循环通过细胞;如果不是空白则复制;粘贴在sheet2中未格式化

Question

我已经和这个问题坐了几个小时，如果有人在这里帮助我，我将非常感激。

我想做什么：

1. 对于sheet1中的所有单元格A10：A180
2. 如果单元格包含YYYY-MM-DD表单上的日期
3. 复制单元格和右侧的两个下一个单元格（例如A11：A13）
4. 删除所有格式，以便仅复制单元格的值/字符串。
5. 在sheet2中的列末尾粘贴
6. 完成后，按日期对条目（整行）进行排序

有什么想法吗？

祝你好运 院长

<小时/> 修改：从评论中复制并粘贴代码：

Private Sub Worksheet_Activate() 
    Sheet2.Cells.Clear 
    Dim R1 As Range, R2 As Range 
    Dim wsFrom As Worksheet, wsTo As Worksheet 
    Set wsFrom = ThisWorkbook.Sheets("Blad1") 
    Set wsTo = ThisWorkbook.Sheets("Blad2") 
    Set R1 = wsFrom.Range("A:B") 
    Set R2 = wsTo.Range("A:B") 
    R1.Copy R2 
End Sub

Answer 1

您的问题中有一些不明确的要点，但是下面的代码应该让您开始了如何使用VBA数组在范围之间正确加载，操作和粘贴值：

Option Explicit

Sub copy_nonblank()
    Dim data() As Variant  ' () creates an array instead of a simple variable
    Dim row_count, col_count, r, c, shift As Integer

    'load data from specified range into an array
    data = ThisWorkbook.Sheets("Blad1").Range("A10:C180").Value2

    ' iterate through rows and shift data up to fill-in empty rows
    row_count = UBound(data, 1)
    col_count = UBound(data, 2)
    shift = 0
    For r = 1 To row_count
        If IsEmpty(data(r, 1)) Then
            shift = shift + 1
        ElseIf shift > 0 Then
            For c = 1 To col_count
                data(r - shift, c) = data(r, c)
            Next c
        End If
    Next r

    ' delete values, but not formatting
    ThisWorkbook.Sheets("Blad2").Cells.ClearContents

    ' paste special as values, but only the shifted non-empty rows
    ThisWorkbook.Sheets("Blad2").Range("A10") _
        .Resize(r - shift - 1, col_count) _
        .Value2 = data
End Sub

您需要手动指定输出表格上的格式，但只需指定一次。