Excel VBA代码复制分布数据并以垂直顺序粘贴
正如你可以在屏幕截图中看到的（我已经提供了下面的截图链接），我有一个包含大量数值数据的Excel工作表。 我已经使用条件格式来突出显示一些数据。 我的最终目标是复制这些突出显示的数据并以垂直顺序将其粘贴到新表中。 但是，我面临的问题是这些数据在许多行和列之间错开。 举例来说， 第120列烧烤会有一个突出的数据。 我想以垂直顺序复制和粘贴所有这些分布在突出显示的数据在一个新的工作表。 我只是不知道什么代码键入:(
任何forms的帮助将不胜感激。 谢谢！
试试下面。 根据需要更改工作表和范围名称。 它将数据加载到数组中，testing每个点是否小于或等于50（向下移动行，然后跨列…但是如果需要，可以切换For语句），如果是，则写入新的工作表。
Sub CopyConditionalData() Dim ws1 As Worksheet, ws2 As Worksheet Set ws1 = Worksheets("Sheet1") ' change as needed Set ws2 = Worksheets("Sheet2") ' change as needed Dim rRng As Range Set rRng = ws1.Range("A1:G100") 'change as needed Dim aRng As Variant aRng = rRng Dim lRows As Long, lCols As Long For lCols = 1 To rRng.Columns.Count For lRows = LBound(aRng) To UBound(aRng) If aRng(lRows, lCols) <= 50 Then ws2.Range("A" & ws2.Rows.Count).End(xlUp).Offset(1) = aRng(lRows, lCols) End If Next Next End Sub
假设Sheet1中有120行和100列数据，突出显示的颜色是黄色，突出显示的数据必须复制到Sheet2，然后
Dim temp As Integer temp = 1 For i = 1 To 120 For j = 1 To 100 Worksheets("Sheet1").Activate If Cells(i, j).Interior.Color = RGB(255, 255, 0) Then x = Cells(i, j).Value Worksheets("Sheet2").Activate Cells(temp, 1).Value = x temp = temp + 1 End If Next j Next i
所以..只需复制50以下的值：]
set cell2 = Worksheets(2).Range("A1") For Each cell in Worksheets(1).UsedRange If Not IsNumeric(cell.Value) And cell.Value <= 50 Then cell2.Value2 = cell.Value2 Set cell2 = cell2.Offset(1) End If Next
我build议删除条件格式，标记matrix（行和列），然后unpivoting（例如如图所示）。
然后用相关的十年标记行（如D1中的10，20，30等），并将创build的表转换为适合的表。