| |
▼Hirofumi さん：
ありがとうございます。返信が遅くなりました。
書いて頂いたコードを使用してみました。
貼り付けはうまくいくのですが、
Sheet2のソート（Ｒ列まであります）がうまくいかず、
色々と試してみたのですが、うまくソートされませんでした。
解決方法をご教授ください。
よろしくお願いします。
>データが無いので試していませんが？
>Sheet1、Sheet2共に列見出しが有る物とします
>Sheet1、Sheet2共に比較する列をKeyとして整列されます
>Sheet1、Sheet2に共通する比較値が有る場合は、
>Sheet2のＣ〜Ｆ列にSheet1のＢ〜Ｅ列の値を貼り付け
>
>Option Explicit
>Option Compare Text
>
>Public Sub DataMatch()
>
> 'Sheet1のデータ列数（A列〜E列）
> Const clngColumns1 As Long = 5
> 'Sheet1の比較する列の列位置(基準セル位置からの列Offset)
> Const clngKeys1 As Long = 0
>
> 'Sheet2のデータ列数（C列〜G列）
> Const clngColumns2 As Long = 5
> 'Sheet2の比較する列の列位置(基準セル位置からの列Offset)
> Const clngKeys2 As Long = 4
>
> Dim i As Long
> Dim j As Long
> Dim lngStart As Long
> Dim rngList1 As Range
> Dim vntList1 As Variant
> Dim lngRows1 As Long
> Dim rngList2 As Range
> Dim vntList2 As Variant
> Dim lngRows2 As Long
> Dim strProm As String
>
> 'Sheet1のA1を基準とします
> Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
>
> 'Sheet2のD1を基準とする
> Set rngList2 = Worksheets("Sheet2").Cells(1, "C")
>
> '画面更新を停止
> Application.ScreenUpdating = False
>
> 'Sheet1の基準に就いて
> With rngList1
> '行数を取得
> lngRows1 = .Offset(Rows.Count - .Row, _
> clngKeys1).End(xlUp).Row - .Row
> 'データが無ければ
> If lngRows1 <= 0 Then
> strProm = rngList1.Value & "にデータが有りません"
> GoTo Wayout
> End If
> 'データをA列で整列
> DataSort .Offset(1).Resize(lngRows1, _
> clngColumns1 + 1), .Offset(1, clngKeys1)
> '比較用配列にデータを取得
> vntList1 = .Offset(1, clngKeys1).Resize(lngRows1 + 1).Value
> End With
>
> 'Sheet2基準に就いて
> With rngList2
> '行数を取得
> lngRows2 = .Offset(Rows.Count - .Row, _
> clngKeys2).End(xlUp).Row - .Row
> 'データが無ければ
> If lngRows2 <= 0 Then
> strProm = rngList2.Value & "にデータが有りません"
> GoTo Wayout
> End If
> 'データをG列で整列
> DataSort .Offset(1).Resize(lngRows2, _
> clngColumns2 + 1), .Offset(1, clngKeys2)
> '比較用配列にデータを取得
> vntList2 = .Offset(1, clngKeys2).Resize(lngRows2 + 1).Value
> End With
>
> 'Sheet2の比較開始位置を設定
> lngStart = 1
> For i = 1 To lngRows1
> For j = lngStart To lngRows2
> 'Matchiした場合
> If vntList1(i, 1) = vntList2(j, 1) Then
> 'Sheet2のＣ〜Ｆ列にSheet1のＢ〜Ｅ列の値を貼り付け
> rngList2.Offset(j).Resize(, 4).Value _
> = rngList1.Offset(i, 1).Resize(, 4).Value
> Else
> 'Sheet1の値がSheet2の値より小さい場合、Forを抜ける
> If vntList1(i, 1) < vntList2(j, 1) Then
> Exit For
> End If
> End If
> Next j
> 'D列の比較開始位置を更新
> lngStart = j
> Next i
>
> strProm = "処理が完了しました"
>
>Wayout:
>
> '画面更新を再開
> Application.ScreenUpdating = True
>
> Set rngList1 = Nothing
> Set rngList2 = Nothing
>
> MsgBox strProm, vbInformation
>
>End Sub
>
>Private Sub DataSort(rngScope As Range, _
> rngKey As Range, _
> Optional lngOrientation As Long = xlTopToBottom)
>
> rngScope.Sort _
> Key1:=rngKey, Order1:=xlAscending, _
> Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
> Orientation:=lngOrientation, SortMethod:=xlStroke
>
>End Sub
|
|
孝彦
- 07/7/24(火) 20:43 -
