Excel VBA質問箱 IV

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

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


37054 / 76732 ←次へ | 前へ→

【44852】Re:複数のシートを利用して・・・
回答  Hirofumi  - 06/12/3(日) 19:45 -

引用なし
パスワード
   Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim rngName As Range
  Dim vntName As Variant
  Dim rngColor As Range
  Dim vntColor As Variant
  Dim rngResult As Range
  Dim lngFound As Long
  Dim strProm As String
  
  'Sheet1Listの左上隅セル位置を基準として設定(列見出し「番号」のセル位置)
  Set rngList = Worksheets("Sheet1").Cells(1, "A")
  
  'Sheet2Listの左上隅セル位置を基準として設定(列見出し「番号」のセル位置)
  Set rngName = Worksheets("Sheet2").Cells(1, "A")
  
  'Sheet1Listの左上隅セル位置を基準として設定(列見出し「Col」のセル位置)
  Set rngColor = Worksheets("Sheet3").Cells(1, "A")
  
  With rngName
    'データ行数を取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    'データが無い場合
    If lngRows <= 0 Then
      strProm = .Parent.Name & "のデータが有りません"
      GoTo Wayout
    End If
    'Sheet2の「番号」列範囲を取得
    Set rngName = .Offset(1).Resize(lngRows)
  End With

  With rngColor
    'データ行数を取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    'データが無い場合
    If lngRows <= 0 Then
      strProm = .Parent.Name & "のデータが有りません"
      GoTo Wayout
    End If
    'Sheet3の「Col」列範囲を取得
    Set rngColor = .Offset(1).Resize(lngRows)
  End With

  With rngList
    'データ行数を取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    'データが無い場合
    If lngRows <= 0 Then
      strProm = .Parent.Name & "のデータが有りません"
      GoTo Wayout
    End If
    '「番号」データを配列に取得
    vntName = .Resize(lngRows + 1).Value
    '「Col」データを配列に取得
    vntColor = .Offset(, 2).Resize(lngRows + 1).Value
  End With
  
  '新規Bookを追加し先頭シートを結果シートとする
  Set rngResult = Workbooks.Add.Worksheets(1).Cells(1, "A")
  'Sheet1のデータ結果シートにCopy
  rngList.Resize(lngRows + 1, 4).Copy Destination:=rngResult
  '結果シートに列を挿入
  With rngResult
    .Offset(, 3).EntireColumn.Insert
    .Offset(, 1).EntireColumn.Insert
  End With
  
  '列見出しを代入
  vntName(1, 1) = rngName(1).Offset(-1, 1).Value
  '列見出しを代入
  vntColor(1, 1) = rngColor(1).Offset(-1, 1).Value
  '探索
  For i = 2 To lngRows + 1
    '氏名を探索
    lngFound = RowSearch(vntName(i, 1), rngName)
    If lngFound > 0 Then
      vntName(i, 1) = rngName(lngFound, 2).Value
    End If
    'Colを探索
    lngFound = RowSearch(vntColor(i, 1), rngColor)
    If lngFound > 0 Then
      vntColor(i, 1) = rngColor(lngFound, 2).Value
    End If
  Next i
    
  '画面更新を停止
  Application.ScreenUpdating = False
  
  With rngResult
    '氏名を出力
    .Offset(, 1).Resize(lngRows + 1).Value = vntName
    'Colを出力
    .Offset(, 4).Resize(lngRows + 1).Value = vntColor
  End With
  
  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngName = Nothing
  Set rngColor = Nothing
  Set rngResult = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private Function RowSearch(vntKey As Variant, _
            rngScope As Range, _
            Optional lngOver As Long, _
            Optional lngMode As Long = 1) As Long

  Dim vntFind As Variant
  
  If rngScope Is Nothing Then
    lngOver = 1
    Exit Function
  End If
  
  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, lngMode)
  'もし、エラーで無いなら
  If Not IsError(vntFind) Then
    'もし、Key値と探索位置の値が等しいなら
    If vntKey = rngScope(vntFind).Value Then
      '戻り値として、行位置を代入
      RowSearch = vntFind
    End If
    'Key値を超える最小値のある行
    lngOver = vntFind + 1
  Else
    lngOver = 1
  End If
  
End Function

0 hits

【44761】複数のシートを利用して・・・ 北風小僧 06/11/30(木) 20:00 質問
【44762】Re:複数のシートを利用して・・・ Statis 06/11/30(木) 20:37 回答
【44765】Re:複数のシートを利用して・・・ 北風小僧 06/11/30(木) 21:18 お礼
【44847】Re:複数のシートを利用して・・・ 北風小僧 06/12/3(日) 16:51 質問
【44852】Re:複数のシートを利用して・・・ Hirofumi 06/12/3(日) 19:45 回答
【44854】Re:複数のシートを利用して・・・ Kein 06/12/3(日) 23:42 回答

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