我相信下面的代码可以满足您的需求。
我创建了此工作表以匹配您的图像：
下面的宏将工作表更改为：
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