Excel VBA質問箱 IV

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

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


14571 / 76734 ←次へ | 前へ→

【67652】Re:AとBを比べて一致したら返す
回答  Hirofumi  - 10/12/21(火) 9:40 -

引用なし
パスワード
   こんなのでは?

Option Explicit
Option Compare Text

Public Sub Sample_1()

  'ブックAの列数(B〜D列)
  Const clngColumns1 As Long = 3
  'ブックAの中のKeyと成る列位置(基準列からのB列の列Offset:0列目)
  Const clngKey1 As Long = 0
  '転記先先頭列位置(基準列からのC列の列Offset:1列目)
  Const clngItem1 As Long = 1
  
  'ブックBの列数(L〜R列)
  Const clngColumns2 As Long = 7
  'ブックBの中のKeyと成る列位置(基準列からのL列の列Offset:0列目)
  Const clngKey2 As Long = 0
  '転記元先頭列位置(基準列からのQ列の列Offset:5列目)
  Const clngItem2 As Long = 5

  Dim i As Long
  Dim j As Long
  Dim lngRows1 As Long, lngRows2 As Long
  Dim rngList1 As Range, rngList2 As Range
  Dim vntKeys1() As Variant, vntKeys2() As Variant
  Dim vntData1() As Variant, vntData2() As Variant
  Dim rngResult As Range
  Dim lngStart As Long
  Dim strPrompt As String
  
  'ブックAの先頭セル位置を基準とする(先頭列の列見出しKeyのセル位置)
'  Set rngList1 = Workbooks("ブックA.xls").Worksheets("シートA").Range("B1")
  Set rngList1 = Worksheets("シートA").Range("B1")

  'ブックBの先頭セル位置を基準とする(先頭列の列見出しKeyのセル位置)
'  Set rngList2 = Workbooks("ブックB.xls").Worksheets("シートB").Range("L1")
  Set rngList2 = Worksheets("シートB").Range("L1")
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  With rngList1
    '行数の取得
'    lngRows1 = .Offset(Rows.Count - .Row, clngKey1).End(xlUp).Row - .Row
    lngRows1 = 3131 - 2 + 1
    If lngRows1 <= 0 Then
      strPrompt = "データが有りません"
      GoTo Wayout
    End If
    '復帰用Keyを設定
    .Offset(, clngColumns1).EntireColumn.Insert
    With .Offset(1, clngColumns1)
      .Value = 1
      .Resize(lngRows1).DataSeries Rowcol:=xlColumns, _
          Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
    End With
    'B列をKeyとして整列
    .Offset(1).Resize(lngRows1, clngColumns1 + 1).Sort _
        Key1:=.Offset(1, clngKey1), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    'Key列データを配列に取得
    vntKeys1 = .Offset(1, clngKey1).Resize(lngRows1 + 1).Value
  End With
  '結果用配列を確保
  ReDim vntData1(1 To lngRows1, 1 To 2)
  
  With rngList2
    '行数の取得
'    lngRows2 = .Offset(Rows.Count - .Row, clngKey2).End(xlUp).Row - .Row
    lngRows2 = 303 - 2 + 1
    If lngRows2 <= 0 Then
      strPrompt = "データが有りません"
      GoTo Wayout
    End If
    '復帰用Keyを設定
    .Offset(, clngColumns2).EntireColumn.Insert
    With .Offset(1, clngColumns2)
      .Value = 1
      .Resize(lngRows2).DataSeries Rowcol:=xlColumns, _
          Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
    End With
    'L列をKeyとして整列
    .Offset(1).Resize(lngRows2, clngColumns2 + 1).Sort _
        Key1:=.Offset(1, clngKey2), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    'Key列データを配列に取得
    vntKeys2 = .Offset(1, clngKey2).Resize(lngRows2 + 1).Value
    '転記データを配列として取得
    vntData2 = .Offset(1, clngItem2).Resize(lngRows2, 2).Value
  End With
  
  'ブックAを検索して見つかったその行をブックAの「抽出データ」を転記
  lngStart = 1
  For i = 1 To lngRows1
    For j = lngStart To lngRows2
      ''ブックAのKeyがブックBのKeyより大きければ
      If vntKeys1(i, 1) < vntKeys2(j, 1) Then
        'Forを抜ける
        Exit For
      Else
        'ブックAのKeyとブックBのKey等しければ
        If vntKeys1(i, 1) = vntKeys2(j, 1) Then
          '出力用配列に転記
          vntData1(i, 1) = vntData2(j, 1)
          vntData1(i, 2) = vntData2(j, 2)
          Exit For
        End If
      End If
    Next j
    If j <= lngRows1 Then
      lngStart = j
    Else
      Exit For
    End If
  Next i
  
  '結果を出力
  With rngList1
    .Offset(1, clngItem1).Resize(lngRows1, 2).Value = vntData1
    '作業列をKeyとして整列
    .Offset(1).Resize(lngRows1, clngColumns1 + 1).Sort _
        Key1:=.Offset(1, clngColumns1), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '作業列を削除
    .Offset(, clngColumns1).EntireColumn.Delete
  End With
  
  With rngList2
    '作業列をKeyとして整列
    .Offset(1).Resize(lngRows2, clngColumns2 + 1).Sort _
        Key1:=.Offset(1, clngColumns2), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '作業列を削除
    .Offset(, clngColumns2).EntireColumn.Delete
  End With
  
  
  strPrompt = "処理が完了しました"
     
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList1 = Nothing
  Set rngList2 = Nothing
  
  MsgBox strPrompt, vbInformation

End Sub
3 hits

【67637】AとBを比べて一致したら返す ののか 10/12/20(月) 17:37 質問
【67640】Re:AとBを比べて一致したら返す UO3 10/12/20(月) 20:28 回答
【67651】Re:AとBを比べて一致したら返す ののか 10/12/21(火) 9:36 お礼
【67657】Re:AとBを比べて一致したら返す UO3 10/12/21(火) 16:24 回答
【67658】Re:AとBを比べて一致したら返す ののか 10/12/21(火) 16:43 お礼
【67652】Re:AとBを比べて一致したら返す Hirofumi 10/12/21(火) 9:40 回答
【67653】Re:AとBを比べて一致したら返す ののか 10/12/21(火) 10:07 お礼

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