遍历单元格；非空则复制；粘贴到 sheet2 未格式化

Question

这个问题我已经坐了几个小时了，如果有人能帮助我，我将不胜感激。

我想做的事情：

对于工作表 1
如果单元格包含 YYYY-MM-DD 格式的日期
复制单元格和右边的下两个单元格（例如A11:A13）
删除所有格式，以便只复制单元格的 value/string。
粘贴到工作表 2 中的列末尾
完成后，按日期对条目（整行）排序

有什么想法吗？

此致院长

编辑：从评论中复制粘贴代码：

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

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

遍历单元格；非空则复制；粘贴到 sheet2 未格式化

Loop through cells; Copy if not blank; Paste in sheet2 unformatted

excel

vba