如果满足条件，则select多个数据范围

我正在尝试从Excel工作表中获取数据。 如果列标题上显示的date是今天的date，则该列的内容需要被复制。 检查完所有列后，最后的数据需要粘贴到另一个表格中。

我已经build立了一个macros从网站获取股票价格。 现在我需要过滤基于date的数据，以便为绘制图表做好准备。 我已经尝试了以下代码的多个变体，但直到现在还没有成功。 复制范围是问题领域。

Sub graphs() Dim d As Date Dim a As Variant Dim f As Variant Dim b As Variant Dim x As Variant Dim col As Variant Dim r As Range Dim j As Range r = ThisWorkbook.Sheets("historic price").Range(Cells(1, 1), Cells(50, 1)) ' this is to copy the first column with company names b = WorksheetFunction.CountA(Rows(1)) For x = 2 To b a = ThisWorkbook.Sheets("historic price").Cells(1, x) ' below 3 lines are to extract date from column header f = WorksheetFunction.Search(" ", a, 10) d = Mid(a, 10, (f - 10)) If d = Date Then r = Union(r, Range(Cells(1, x), Cells(50, x))) ' this is to add data to r End If Next x col = r.Columns.Count ' count number of columns stored in r r.Copy Worksheets("graphs").Activate Set j = ThisWorkbook.Sheets("Graphs").Range(Cells(1, 1), Cells(50, col)) j.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False ThisWorkbook.Sheets("Graphs").Cells(1, 1).Select End Sub 

Answer 1

你需要设置新的范围

例如

 Set rng1 = .Range("A1") Set rng2 = .Range("A2") Set NewRng = .Range(rng1.Address & ":" & rng2.Address) 

要么

  Set newRng = Union(rng1, rng2) 

所以你需要设置r

 set r = Union(r, Range(Cells(1, x), Cells(50, x)))