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

我一直坐在这个问题上几个小时，如果有人能帮助我，我将非常感激。

我想做的事：

1. 对于sheet1中的所有单元格A10：A180
2. 如果单元格包含YYYY-MM-DDforms的date
3. 复制单元格和右边的两个下一个单元格（例如A11：A13）
4. 删除所有格式，以便只复制单元格的值/string。
5. 粘贴到sheet2的列末尾
6. 完成后，按datesorting条目（整行）

有什么想法吗？

最好的问候院长

---

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

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 

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