循环穿过细胞;如果不是空白，则复制;粘贴到未格式化的工作表 2 中

Question

我已经坐了几个小时了，如果这里有人可以帮助我，我将不胜感激。

我想做什么：

1. 对于工作表10中的所有单元格A1：A180
2. 如果单元格包含 YYYY-MM-DD 格式上的日期
3. 复制单元格和右侧的两个下一个单元格（例如 A11：A13）
4. 删除所有格式，以便仅复制单元格的值/字符串。
5. 粘贴在工作表2的列末尾
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

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