Excel VBA質問箱 IV

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

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


18486 / 76736 ←次へ | 前へ→

【63692】Re:教えて下さい
お礼  黄身  - 09/11/30(月) 12:24 -

引用なし
パスワード
   ▼Hirofumi さん:
できました!!
1時から発表なので今手作業でやってたんですが、ほんと助かりました!
ありがとうございました!


>Sheet1、Sheet2共に列見出しが在る物とします
>
>Option Explicit
>
>Public Sub DataMatch3()
>
>'  同一データのチェック
>'  Dictionary版
>
>  'Sheet1のデータ列数(A列)
>  Const clngColumns1 As Long = 1
>  'Sheet1のKey列(A列)の位置設定(基準位置からの列Offset)
>  Const clngKey1 As Long = 0
>  
>  'Sheet2のデータ列数(A列〜B列)
>  Const clngColumns2 As Long = 2
>  'Sheet2のKey列(A列)の位置設定(基準位置からの列Offset)
>  Const clngKey2 As Long = 0
>  
>  Dim i As Long
>  Dim rngList1 As Range
>  Dim lngRows1 As Long
>  Dim vntKeys1 As Variant
>  Dim rngList2 As Range
>  Dim lngRows2 As Long
>  Dim vntKeys2 As Variant
>  Dim rngResult As Range
>  Dim lngWrite As Long
>  Dim dicIndex As Object
>  Dim strProm As String
>
>  'Sheet1データシートのA1を基準とします
>  Set rngList1 = Worksheets("Sheet1").Range("A1")
>  
>  'Sheet2データシートのA1を基準とする
>  Set rngList2 = Worksheets("Sheet2").Range("A1")
>  
>  'Sheet3結果シートのA1を基準とする
>  Set rngResult = Worksheets("Sheet3").Range("A1")
>
>  'Dictionaryオブジェクトを取得
>  Set dicIndex = CreateObject("Scripting.Dictionary")
>  
>  '画面更新を停止
>  Application.ScreenUpdating = False
>    
>  'Sheet1の基準に就いて、Key列データと行数取得
>  If Not GetBasicData(rngList1, lngRows1, clngKey1, vntKeys1) Then
>    strProm = rngList1.Parent.Name & "にデータが有りません"
>    GoTo Wayout
>  End If
>  
>  'Sheet2の基準に就いて、Key列データと行数取得
>  If Not GetBasicData(rngList2, lngRows2, clngKey2, vntKeys2) Then
>    strProm = rngList2.Parent.Name & "にデータが有りません"
>    GoTo Wayout
>  End If
>  
>  'Sheet2のKeyデータと行位置をDictionaryに登録
>  With dicIndex
>    '最終行に達するまで繰り返し
>    For i = 1 To lngRows2
>      'Dictionaryに登録
>      .Item(vntKeys2(i, 1)) = i
>    Next i
>    'Sheet1のKeyデータをDictionaryで比較し在ったら転記
>    For i = 1 To lngRows1
>      'Dictionaryに登録が有る場合集計
>      If .Exists(vntKeys1(i, 1)) Then
>        '出力位置を更新
>        lngWrite = lngWrite + 1
>        'Sheet3のA列にSheet2シートの該当行を出力
>        rngList2.Offset(.Item(vntKeys1(i, 1))).Resize(, clngColumns2).Copy _
>            Destination:=rngResult.Offset(lngWrite)
>      End If
>    Next i
>  End With
>  
>  strProm = "処理が完了しました"
>  
>Wayout:
>  
>  '画面更新を再開
>  Application.ScreenUpdating = True
>  
>  Set dicIndex = Nothing
>  Set rngList1 = Nothing
>  Set rngList2 = Nothing
>  Set rngResult = Nothing
>  
>  MsgBox strProm, vbInformation
>  
>End Sub
>
>Private Function GetBasicData(rngList As Range, _
>                lngRows As Long, _
>                lngKeys As Long, _
>                vntData As Variant) As Boolean
>
>  '基準に就いて
>  With rngList
>    '行数を取得
>    lngRows = .Offset(Rows.Count - .Row, lngKeys).End(xlUp).Row - .Row
>    'データが無ければFunctionを抜ける(戻り値=False)
>    If lngRows <= 0 Then
>      Exit Function
>    End If
>    '比較用配列にデータを取得
>    vntData = .Offset(1, lngKeys).Resize(lngRows + 1).Value
>  End With
>  
>  GetBasicData = True
>
>End Function
0 hits

【40838】教えて下さい 初心者 06/7/25(火) 3:55 質問
【40842】Re:教えて下さい だるま 06/7/25(火) 8:28 回答
【40846】Re:教えて下さい 注意 06/7/25(火) 9:22 発言
【40980】Re:教えて下さい 初心者 06/7/27(木) 11:04 お礼
【40898】Re:教えて下さい Hirofumi 06/7/25(火) 21:05 回答
【40981】Re:教えて下さい 初心者 06/7/27(木) 11:09 お礼
【63685】Re:教えて下さい 黄身 09/11/30(月) 3:51 質問
【63686】Re:教えて下さい Hirofumi 09/11/30(月) 8:46 回答
【63687】Re:教えて下さい 黄身 09/11/30(月) 9:08 発言
【63691】Re:教えて下さい Hirofumi 09/11/30(月) 12:13 回答
【63692】Re:教えて下さい 黄身 09/11/30(月) 12:24 お礼

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