Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


31795 / 76738 ←次へ | 前へ→

【50187】Re:Vlookupについて
回答  Hirofumi  - 07/7/13(金) 17:39 -

引用なし
パスワード
   データが無いので試していませんが?
Sheet1、Sheet2共に列見出しが有る物とします
Sheet1、Sheet2共に比較する列をKeyとして整列されます
Sheet1、Sheet2に共通する比較値が有る場合は、
Sheet2のC〜F列にSheet1のB〜E列の値を貼り付け

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のC〜F列にSheet1のB〜E列の値を貼り付け
        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

2 hits

【50182】Vlookupについて 孝彦 07/7/13(金) 15:32 質問
【50183】Re:Vlookupについて かみちゃん 07/7/13(金) 15:50 発言
【50187】Re:Vlookupについて Hirofumi 07/7/13(金) 17:39 回答
【50424】Re:Vlookupについて 孝彦 07/7/24(火) 20:43 質問
【50428】Re:Vlookupについて Hirofumi 07/7/24(火) 21:25 回答
【50431】Re:Vlookupについて 孝彦 07/7/24(火) 21:59 お礼

31795 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free