使用来自另一个单元的超链接匹配/替换单元数据

Question

我正在做大量的手工工作，我尝试找到相关的宏，但遗憾的是找不到。

基本上，我的Excel工作表有4列（A，B，C，D）。在对当前月份的公司文件进行大量筛选之后，我留下了A列和B列中的数据（我删除了我的范围之上和之下的某些marcaps，我删除了与我的部门无关的数据等）。

• A栏有公司名称（大写，小写，有时是组合）

• B栏有日期（我现在按月做）

这两个列准备就绪后，我会从网站上运行一个网页查询，下载整个月的SEC文件，并附上超链接。

• C栏的公司名称为HYPERLINKS（不一定与Col A中的案例格式相同）

• D栏有日期（我每月下载，因此将是同月）

C列的数据远远超过Col A;它也有所有不需要的公司的超链接，并且没有办法在该网站上进行搜索，而不是在目前的范围内进行定制。

Col D比Col B长得多，因为提交的文件更多

e.g：

Col A   Col B        Col C          Col D
                     (Hyperlinks)
Abc     3/1/2008     AAA            3/1/2008
BCD     3/1/2008     AAB            3/1/2008
BCD     3/2/2008     AAC            3/1/2008 
cDE     3/2/2008     ABC            3/1/2008
DeF     3/3/2008     ABE            3/1/2008
                     BCD            3/1/2008
                     ABC            3/2/2008
                     BCD            3/2/2008
                     CDE            3/2/2008
                     AAA            3/3/2008
                     AAF            3/3/2008
                     DEF            3/3/2008

我需要Col C中的公司将Col A替换为其超链接，前提是它们在同一天（Col B = Col D），无论情况如何（公司名称都是唯一的）。

Col A和C中的公司的顺序不一样，即使我为这些列排序'AZ'，因为Col C中不需要公司的数据.C是比A更长的列。

每个月有1200到1500份文件，我正在手动检查并按日期手动更换。我必须这样做3年，过去10天我仍然在同一个月。还有更多：我必须打开每个文件并阅读并更新备注栏。

Answer 1

我相信下面的代码可以满足您的需求。

我创建了此工作表以匹配您的图片：

下面的宏将工作表更改为：

列C和D现在是重新排列的，因为这些列中的每个值都已移动到F和G列。

希望这有帮助。

修改

Meena针对她的数据运行宏，但它与所有应该匹配的值不匹配。她通过电子邮件向我发送了她的数据副本。在检查了她的数据之后，我对下面的宏做了三处修改：

• Meena的工作表没有标题行。我使用常量来指定第一个数据行。我已将值从2更改为1.
• 许多参考值都有尾随空格。我已经使用TRIM（）在比较之前删除了那些尾随空格。
• 宏创建两个新的数据列。这些是保留默认宽度，所以如果值很长，它将换行并需要几行。我现在添加了代码来将列宽从源列复制到目标列。

 Option Explicit
  ' If the columns have to be moved, update these constants
  ' and the code will change to match.
  Const ColRefCompany As Long = 1
  Const ColRefDate As Long = 2
  Const ColWebCompany As Long = 3
  Const ColWebDate As Long = 4
  Const ColSaveCompany As Long = 6
  Const ColSaveDate As Long = 7
  Const ColLastLoad As Long = 4
  Const RowDataFirst As Long = 1        ' No header row
Sub CopyWebValuestoSaveColumns()

  Dim CellValue() As Variant
  Dim ColCrnt As Long
  Dim Rng As Range
  Dim RowRefCrnt As Long
  Dim RowSave() As Long
  Dim RowSaveCrnt As Long
  Dim RowWebCrnt As Long
  Dim RowLast As Long

  ' Find the last cell with a value
  With Worksheets("Sheet1")
    Set Rng = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlFormulas, _
                          LookAt:=xlWhole, SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious)

   If Rng Is Nothing Then
     Call MsgBox("Sheet is empty", vbOKOnly)
     Exit Sub
   End If
   RowLast = Rng.Row
   ' Load all reference and web values to CellValue.  Searching an array
   ' is faster than searching the worksheet and hyperlinks are converted
   ' to their display values which gives an easier comparison.
   ' Note for arrays loaded from a worksheet, dimension one is for rows
   ' and dimension two is for columns.
   CellValue = .Range(.Cells(1, 1), .Cells(RowLast, ColLastLoad)).Value

   ' RowSave() will record the position in the save columns of the values
   ' in the web columns.  Allow for one entry per row in web list.
   ReDim RowSave(1 To RowLast)

   RowRefCrnt = RowDataFirst

   ' Set web company names to lower case and remove leading and trailing
   ' spaces ready for matching
   For RowWebCrnt = RowDataFirst To RowLast
     CellValue(RowWebCrnt, ColWebCompany) = _
                               Trim(LCase(CellValue(RowWebCrnt, ColWebCompany)))
   Next

   Do While True
     If CellValue(RowRefCrnt, ColRefCompany) = "" Then
       ' Empty cell in reference company column.  Assume end of list
       Exit Do
     End If
     ' This loop makes no assumptions about the sequence of the
     ' Reference and Web lists.  If you know their sequences match or
     ' if you can sort the two pairs of columns, this loop could be
     ' made faster
     ' Set reference company name to lcase and remove leading and trailing
     ' spaces ready for matching
     CellValue(RowRefCrnt, ColRefCompany) = _
                              Trim(LCase(CellValue(RowRefCrnt, ColRefCompany)))

     For RowWebCrnt = RowDataFirst To RowLast
       If CellValue(RowRefCrnt, ColRefCompany) = _
                                      CellValue(RowWebCrnt, ColWebCompany) And _
          CellValue(RowRefCrnt, ColRefDate) = _
                                          CellValue(RowWebCrnt, ColWebDate) Then
         ' Reference and web values match.
         ' Record that the web values from row RowWebCrnt
         ' are to be copied to row RowRefCrnt
         RowSave(RowWebCrnt) = RowRefCrnt
         Exit For
       End If
     Next
     RowRefCrnt = RowRefCrnt + 1
   Loop
   RowSaveCrnt = RowRefCrnt     ' First row in save column that is available
                                ' for unused web values
   For RowWebCrnt = RowDataFirst To RowLast
     If RowSave(RowWebCrnt) = 0 Then
       ' The web values on this row has not been matched to reference values.
       ' Record these web values are to be moved to the next available row
       ' in the save columns
       RowSave(RowWebCrnt) = RowSaveCrnt
       RowSaveCrnt = RowSaveCrnt + 1
     End If
   Next

   .Columns(ColSaveCompany).ColumnWidth = .Columns(ColWebCompany).ColumnWidth
   .Columns(ColSaveDate).ColumnWidth = .Columns(ColWebDate).ColumnWidth

   ' Copy values from web columns to save columns
   For RowWebCrnt = RowDataFirst To RowLast
     .Range(.Cells(RowWebCrnt, ColWebCompany), _
            .Cells(RowWebCrnt, ColWebDate)).Copy _
                       Destination:=.Cells(RowSave(RowWebCrnt), ColSaveCompany)
   Next

  End With

End Sub