Question

我有一张包含32列数据的工作表，从第2行开始到LastRow。第一行是标题行。多列包含超链接公式（“D”，“F”，“R”，“S”，“X”，“Z”和“AA”），其他列包含一般值。我想用D列中不包含特定值的行填充数组。这些值是超链接公式的一部分。例如，在D3中有= HYPERLINK（＆＃34; http://www.uniprot.org/uniprot/P35222＆＃34;，＆＃34; CTNNB1＆＃34;），我根据第二组引号内的值进行过滤“ CTNNB1” 。我想在新表上输出这个数组。代码如下运行，但不输出任何数据。该代码包含解释步骤和问题的注释。请帮我修改代码或建议一些有效的方法。非常感谢你提前。

一旦识别出满足条件的行，如何逐行创建数组以及如何在“Access”工作表上正确输出它？

NSTimer

Answer 1

第1期

Dim i, j, k, m, LastRow, openPos, closePos As Integer 'As Long

这声明i，j，k将openPos声明为Variants，并将closePos声明为Integer，如果在一个Dim statement中列出多个变量，则必须为每个变量指定一个自己的类型

请勿使用Integer类型。对于VBA，“Integer”声明一个16位整数，需要在32位或64位计算机上进行特殊处理。 Long现在是推荐的类型。

我很少在一个Dim statement中放置几个变量。它节省了一点点打字，但我更喜欢按字母顺序在每行声明一个变量。

请不要声明名称为i，j和k的变量。如果这是一个“快速写入”宏，然后将被丢弃，名称可能无关紧要。但是，如果您可能在六个月内返回此宏，您会记得i，j和k是什么吗？有意义的名称需要更长时间才能输入，但使代码更容易阅读和理解。

第2期

With ActiveSheet
  LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

活动工作表是默认工作表，因此指定其用途并不是很有用。

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

会产生完全相同的效果。

但我希望你写With Worksheets(“xxxx”)。如果使用活动工作表，则依赖于在启动宏时打开所需工作表的用户。如果您在六个月内返回此宏，您还记得哪个工作表是必需的工作表吗？ Sheets.Add使新工作表成为活动工作表。如果您必须记住哪张表是活动表，那么您的代码会变得非常混乱。

第3期

ReDim Result(LastRow - 1)

下标的格式为：[ Lower To] Upper 。

如果省略“[ Lower To]”，Option Base statement的值将确定下限的值。我不记得曾见过Option Base statement，但我仍然喜欢明确。 VBA在允许你有不同的下界方面是不寻常的;对于大多数语言，它固定为零。使用VBA，我可以写：ReDim Result(2 To LastRow)。我总是将我的下限设置为当时我认为最有帮助的每个值。

如果VBA创建一个数组（例如使用Split），那么该数组的下限几乎总是为零。我能想到的唯一例外是将范围复制到Variant时。这里得到的数组的下限为1。

您将Result设置为一维，但将其用作二维数组。我想你想要：

ReDim Result(1 To LastRow-1, 1 To 27)

第4期

On Error Resume Next

你应该只使用这样的语句：

On Error Resume Next
Statement that might fail
On Error GoTo 0
If Err.Number > 0 Then
   Test or display Err.Number or Err.Description
End If

当您无法避免Excel遇到错误时，您应该只使用On Error。例如，打开您可能没有读取权限的文件时。在这种情况下，On Error允许您向用户提供有用的消息，或者可以通过尝试使用其他文件来恢复。您不使用它来避免算术错误。

第5期

If Application.ReferenceStyle = xlR1C1 Then
  Str = .Cells(i, 4).FormulaR1C1
Else
  Str = .Cells(i, 4).Formula
End If

Application.ReferenceStyle会影响公式的显示方式。 VBA宏可以请求任一样式。选择您喜欢的公式样式，但超链接不应受您选择的影响。

第6期

在从超链接公式中提取显示文本之前，必须检查单元格是否包含超链接公式。虽然在公式中搜索最后两个双引号没有任何问题，但此宏使用了不同的技术。使用此技术，您寻找的值位于CellPart(1)。

Option Explicit
Sub Demo()

  Dim CellFormula As String
  Dim CellPart() As String
  Dim RowCrnt As Long
  Dim RowLast As Long

  With Worksheets("Data")       ‘ Replace with the name of your worksheet
    RowLast = .Cells(Rows.Count, "D").End(xlUp).Row

    For RowCrnt = 2 To RowLast
      CellFormula = .Cells(RowCrnt, "D").Formula
      If Left(CellFormula, 11) = "=HYPERLINK(" Then
        ' It is possible to make all these changes to CellFormula in one go
        ' but this is better for showing what I am doing
        CellFormula = Mid(CellFormula, 12)
        CellFormula = Mid(CellFormula, 1, Len(CellFormula) - 1)
        CellFormula = Replace(CellFormula, """", "")
        CellPart = Split(CellFormula, ",")
        Debug.Print CellPart(0) & "  " & CellPart(1)
      End If
    Next

  End With

End Sub

**第7期**

在你的宏中你是：

向下扫描列D，查找感兴趣的行。
将感兴趣的行的单元格复制到数组中。

您对最终数组没有任何作用，但我认为您打算将其写入新工作表。

此技术涉及将每个感兴趣的单元格从工作表单独移动到阵列。这并不像有些人想的那么慢，但在我看来这不是最简单的方法。

您已使用LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row查找包含数据的最后一行。 VBA提供了几种查找最后一行和列的方法，这通常是最容易使用的方法。但是，没有一种可用的方法适用于所有情况。这种技术依赖于程序员知道哪一列（或行）包含最多的数据。

我用过：

RowLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
ColLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column

第一个语句查找任何列中最后一个使用过的单元格，而第二个语句查找任何行中最后一个使用过的单元格。这些语句不依赖于程序员知道哪一列具有最后一行或哪一行具有最后一列。如果您的数据不是矩形，它们也很有用。

在这个宏中，我已将工作表中每个单元格的每个公式都拉到一个语句中的数组中。然后我显示了前十行和列，以便您可以看到我导入的内容。

Sub Demo2()

  Dim CellValue As Variant
  Dim ColCrnt As Long
  Dim ColLast As Long
  Dim RowCrnt As Long
  Dim RowLast As Long

  With Worksheets("Data")       ' Replace with the name of your worksheet

    RowLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
    ColLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column

    CellValue = .Range(.Cells(1, 1), .Cells(RowLast, ColLast)).Formula

    For RowCrnt = 1 To 10
      For ColCrnt = 1 To 10
        Debug.Print "[R" & RowCrnt & "C" & ColCrnt & "]" & CellValue(RowCrnt, ColCrnt);
      Next
      Debug.Print
    Next

  End With

End Sub

您可能需要增加10的结束值以查看足够的数据，但此宏表明我可以将工作表中的每个值和公式下载到包含单个语句的数组中。

我建议您创建像我一样的小宏，在您不确定该功能时会探索单个功能。完整宏的问题在于你不知道它出了什么问题。使用单个功能宏时，没有什么可以混淆图片，因为您尝试了不同的功能。如果你无法使它工作，单个功能宏将比混乱的多功能宏更快地得到Stack Overflow的答案。

完整解决方案

上面我已经探讨了如何访问数据以及如何决定感兴趣的行。我想我们现在已做好最后的决定了。

有几种方法对我而言并不明显哪种方法会更好。

对于第1步，我相信将工作表导入数组并在内存中识别有趣的行是最好的方法。另一种方法是，在工作表中读取D列，没有我能看到的优点。

对于第2步，我可以看到三种不同的方法，与第1步不同：

将整个工作表复制到数组中。将有趣的行复制到不同的数组。将第二个数组复制到新工作表。
将工作表的D列复制到数组中。使用该数组来识别有趣的行。将识别出来的有趣行从原始工作表复制到新工作表。
将工作表的D列复制到数组中。使用该数组来识别有趣的行。将Union用于包含所有有趣行的单个范围，并将它们作为一个单元从原始工作表复制到新工作表。

我从未尝试过方法3，尽管我通过使用AutoFilter选择行然后将可见行复制到新位置来做类似的事情。但是，我没有看到它提供了超过方法2的任何东西，并且我遇到了非常大的工会的问题所以我忽略了方法3.

您只能将值和公式复制到数组中，因此您将失去任何格式化方法1.方法1可能比方法2更快。方法2看起来好像编码更简单。

除了可能需要保留格式之外，我无法看到这两种方法的主要优势。由于格式化可能对此项目或类似项目很重要，因此我决定采用方法2。

与方法2无关，但您说您不知道如何ReDim Preserve结果删除未使用的行。答案是你不能方便地删除这些行，但这没关系。您只能使用ReDim Preserve来更改数组最后一个维度的大小。从工作表读取或准备写入工作表的数组将工作表列作为第二维。您可以使用工作表函数Transpose切换维度，ReDim数组，然后再切换Transpose。但是，我发现一些（可能是所有）工作表函数非常慢。以VBA编码的转置比Excel版本快。从键盘调用时，工作表函数看起来非常合适，因此缓慢可能是界面的开销。但是，在将数组写入工作表时，未使用的尾随行无关紧要，除非它们可能会覆盖您希望保留的行。

以下是我对你的宏的尝试。我没有太多合适的测试数据，但似乎按要求工作。

Sub NewAa()

  ' Change these names as required
  Const WshtSrcName As String = "Data"
  Const WshtExtName As String = "Extract"

  Dim CellFormula As String
  Dim CellPart() As String
  Dim CellValue As Variant
  Dim Found As Boolean
  Dim InxNTBE
  Dim NotToBeExtracted() As Variant
  Dim RowExtCrnt As Long
  Dim RowSrcCrnt As Long
  Dim RowSrcLast As Long
  Dim WshtSrc As Worksheet
  Dim WshtExt As Worksheet

  ' If you are going to be extracting different hyperlinks, an array is easier
  ' to amend than an If statement
  NotToBeExtracted = Array("Q61R", "I391M", "V600E", "PIC3CA", "BRAF", "EGFR")

  Set WshtSrc = Worksheets(WshtSrcName)

  Worksheets.Add After:=Worksheets(Worksheets.Count)
  ' The new worksheet is now the active worksheet
  ActiveSheet.Name = WshtExtName
  Set WshtExt = ActiveSheet

  With WshtSrc

    RowSrcLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row

    ' Import column D
    CellValue = .Range(.Cells(1, "D"), .Cells(RowSrcLast, "D")).Formula
    ' CellValue will be an array with dimensions (1 To RowLast, 1 to 1).
    ' Note the lower bounds for such arrays are always one even when column 4 has been imported.

  End With

  ' Copy header row
  WshtSrc.Rows(1).Copy Destination:=WshtExt.Cells(1, 1)
  ' Note the format of copy range is: Xxxxx.Copy Destination:=Yyyyy
  ' where:
  '   Xxxxx is the range to be copied
  '   Yyyyy is the top left cell of the destination range
  '   "Destination:=" is optional but  think it add clarity.

  RowExtCrnt = 2

  For RowSrcCrnt = 2 To RowSrcLast

    CellFormula = CellValue(RowSrcCrnt, 1)
    If Left(CellFormula, 11) = "=HYPERLINK(" Then
      ' Format is: =HYPERLINK("Xxxx","Yyyy")
      ' Extract Yyyy to CellPart(1)
      CellFormula = Mid(CellFormula, 12)
      CellFormula = Mid(CellFormula, 1, Len(CellFormula) - 1)
      CellFormula = Replace(CellFormula, """", "")
      CellPart = Split(CellFormula, ",")
      ' Attempt to match CellFormula against one of the hyperlink texts
      ' that are not to be extracted
      Found = False
      For InxNTBE = LBound(NotToBeExtracted) To UBound(NotToBeExtracted)
        If CellPart(1) = NotToBeExtracted(InxNTBE) Then
          Found = True
          Exit For
        End If
      Next
      If Not Found Then
        ' This hyperlink is to be extarcted
        WshtSrc.Rows(RowSrcCrnt).Copy Destination:=WshtExt.Cells(RowExtCrnt, 1)
        RowExtCrnt = RowExtCrnt + 1
      End If
    End If
  Next

End Sub

使用不符合特定条件的行填充数组并保留超链接公式

1 个答案: