Excel VBA質問箱 IV

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

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


2503 / 13645 ツリー ←次へ | 前へ→

【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 お礼[未読]

【67637】AとBを比べて一致したら返す
質問  ののか  - 10/12/20(月) 17:37 -

引用なし
パスワード
   いつもお世話になっております。
簡単なことかもしれませんが助けてください。

ブックAシートAのB2とブックBシートBのL2〜L303から検索して一致した行のQ2とR2の値をファイルAシートAのC2、D2に入力する。
この作業をブックAシートAのB2〜B3131まで繰り返す。

データはブックAはB2〜B3131、ブックBはL2〜L303までです。

というプログラムを組みたいのですが・・・。
宜しくお願い申し上げます。

【67640】Re:AとBを比べて一致したら返す
回答  UO3  - 10/12/20(月) 20:28 -

引用なし
パスワード
   ▼ののか さん:

こんばんは
いくつか、方法があるかともいますが、効率的には「中くらい」のコードです。
シート上のデータの数(行数)は、動的に取得することもできますが、とりあえず
ご提示の領域に固定してあります。

Sub Sample()
 Dim dic As Object
 Dim c As Range
 Dim shB As Worksheet
 
 Application.ScreenUpdating = False
 Set dic = CreateObject("Scripting.Dictionary")
 Set shB = Workbooks("B.xls").Worksheets("B")
 With shB
  For Each c In .Range("L2:L303")
   dic(c.Value) = c.Row
  Next
 End With
 
 With Workbooks("A.xls").Worksheets("A")
  For Each c In .Range("B2:B3131")
   With c.Offset(0, 1).Resize(, 2)
    .ClearContents
    If dic.exists(c.Value) Then
     .Value = shB.Cells(dic(c.Value), "Q").Resize(, 2).Value
    End If
   End With
  Next
 End With
 
 Set dic = Nothing
 Set shB = Nothing
 Application.ScreenUpdating = True
 
End Sub

【67651】Re:AとBを比べて一致したら返す
お礼  ののか  - 10/12/21(火) 9:36 -

引用なし
パスワード
   UO3 さま

早速のご回答有難うございます。
うまくいきました。処理も時間がかからず完璧でした。
データ処理の納期が迫っていたので本当に助かりました。
有難うございます。
お手間でなければ、データ数の自動取得のプログラムも
ご教授願いたいのですが・・・

【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

【67653】Re:AとBを比べて一致したら返す
お礼  ののか  - 10/12/21(火) 10:07 -

引用なし
パスワード
   Hirofumiさん
ありがとうございます。
ですが、私には難しすぎてこんなに長いのは理解できません。
頭がパンクしそうです(^_^;)
みなさん、さすがですね(>_<)
私も勉強して頑張ります。
有難うございました。

【67657】Re:AとBを比べて一致したら返す
回答  UO3  - 10/12/21(火) 16:24 -

引用なし
パスワード
   ▼ののか さん:

サンプルです。

Sub Sample1()
'A.xls の シート A の B列の値がある最終行を求める。
'1行目から下に空白行がない場合のみ。
 Dim z As Long
 With Workbooks("A.xls").Sheets("A")
  z = .Range("B1").End(xlDown).Row
  MsgBox "最終行は" & z & "行目です"
 End With
End Sub

Sub Sample2()
'A.xls の シート A の B列の値がある最終行を求める。
'間に空白行があった場合もOK。
 Dim z As Long
 With Workbooks("A.xls").Sheets("A")
  z = .Range("B" & .Rows.Count).End(xlUp).Row
  MsgBox "最終行は" & z & "行目です"
 End With

End Sub

【67658】Re:AとBを比べて一致したら返す
お礼  ののか  - 10/12/21(火) 16:43 -

引用なし
パスワード
   なるほど(^^♪
参考になります。
ありがとうございました。

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