以下のコードはあなたが求めていることを実行すると思います。
私はあなたのイメージに一致するようにこのワークシートを作成しました：
以下のマクロは、ワークシートを次のように変更します。
列CとDは、これらの列のすべての値が列FとGに移動されたため、冗長になりました。
お役に立てれば。
編集
Meenaは自分のデータに対してマクロを実行しましたが、一致するはずのすべての値と一致しませんでした。彼女は自分のデータのコピーを私にメールで送ってくれました。彼女のデータを調べた後、以下のマクロに3つの変更を加えました。
- Meenaのワークシートには見出し行がありません。定数を使用して最初のデータ行を指定します。値を2から1に変更しました。
- 参照値の多くには末尾にスペースがあります。比較の前に、TRIM（）を使用してこれらの末尾のスペースを削除しました。
- マクロは、2つの新しいデータ列を作成します。これらはデフォルトの幅のままであるため、値が長い場合、折り返され、数行が必要になります。これで、ソース列から宛先列に列幅をコピーするコードを追加しました。
。
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