Excel VBA質問箱 IV

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

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


7120 / 13644 ツリー ←次へ | 前へ→

【41046】お願いします。 どてかぼちゃ 06/7/28(金) 12:16 質問[未読]
【41048】Re:お願いします。 inoue 06/7/28(金) 12:41 発言[未読]
【41049】Re:お願いします。 注意 06/7/28(金) 12:42 発言[未読]
【41089】Re:お願いします。 Hirofumi 06/7/28(金) 21:15 回答[未読]
【41090】Re:お願いします。 Kein 06/7/28(金) 21:50 回答[未読]
【41091】Re:お願いします。 Kein 06/7/28(金) 21:52 発言[未読]

【41046】お願いします。
質問  どてかぼちゃ  - 06/7/28(金) 12:16 -

引用なし
パスワード
   お願いします。教えてください。
シート1にA列に番号、B列に氏名が入っています。1000名くらい。
シート2にD列に氏名が入力されています。300名くらい
シート2の氏名とシート1の氏名が同じならば、
シート2のC列にシート1の同じ名前のA列の番号を転記したいと思います。
また、シート2の氏名がシート1の氏名になかったならば氏名がない事を
シート2のC列に何かを記号を表記したいと思います。
どうしたらいいのかわからないので、教えてください。

【41048】Re:お願いします。
発言  inoue E-MAILWEB  - 06/7/28(金) 12:41 -

引用なし
パスワード
   >どうしたらいいのかわからないので、教えてください。
双方に値をセットするので関数だと面倒でしょうか。
不可能ではないような気がします。
MATCH関数、INDEX関数あたりを調べてみてはいかがでしょう。

VBAでというなら、ループ処理の中で順に判断させるコードを書くのだと
思いますが、基本的にこれらのコードは理解されていますか?

【41049】Re:お願いします。
発言  注意  - 06/7/28(金) 12:42 -

引用なし
パスワード
   VBA質問箱基本ポリシー
http://www.vbalab.net/bbspolicy.html
>タイトルは内容を示すものに
>記事のタイトルは、その質問の内容が端的にわかるようなものにしてください。
>単に「教えてください」とか「困っています」などといったタイトルでは、回答
>者があなたの質問をクリックしない可能性が非常に高くなります。すなわち、回
>答がつかない可能性が高くなる、ということです。

【41089】Re:お願いします。
回答  Hirofumi  - 06/7/28(金) 21:15 -

引用なし
パスワード
   試して無いけど、こんな物で出来るかも?
ただし、夫々のシートには、列見出しが有る物とします
また、Sheet1、Sheet2共に同一シート内では重複が無い物とします

Option Explicit
Option Compare Text

Public Sub UpDate()

  '"Sheet1"のデータ列数(A〜B列)
  Const clngColumns1 As Long = 2
  '"Sheet1"の比較Key列位置(基準からB列の列Offset値)
  Const clngKeys1 As Long = 1
  
  '"Sheet2"のデータ列数(A列〜D列)
  Const clngColumns2 As Long = 4
  '"Sheet2"の比較Key列位置(基準からD列の列Offset値)
  Const clngKeys2 As Long = 3
  
  'C列に書き込む記号
  Const cstrSign As String = "*"
  
  Dim i As Long
  Dim rngList1 As Range
  Dim lngEnd1 As Long
  Dim vntData1 As Variant
  Dim lngRow1 As Long
  Dim vntItems As Variant
  Dim rngList2 As Range
  Dim lngEnd2 As Long
  Dim vntData2 As Variant
  Dim lngRow2 As Long
  Dim vntResult As Variant
  Dim strProm As String

  'Sheet1のA1を基準とします(列見出し先頭のセル位置)
  Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
  
  'Sheet2のA1を基準とする(列見出し先頭のセル位置)
  Set rngList2 = Worksheets("Sheet2").Cells(1, "A")
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '"Sheet1"データの基準に就いて基礎データの取得
  If Not GetBasicData(rngList1, lngEnd1, _
      clngColumns1, clngKeys1, vntData1) Then
    strProm = rngList1.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  '"Sheet1"のA列を配列に取得
  vntItems = rngList1.Offset(1).Resize(lngEnd1 + 1).Value
  
  '"Sheet2"データの基準に就いて基礎データの取得
  If Not GetBasicData(rngList2, lngEnd2, _
      clngColumns2, clngKeys2, vntData2) Then
    strProm = rngList2.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  '"Sheet2"のD列に出力する為の配列を確保します
  ReDim vntResult(1 To lngEnd2, 1 To 1)
  
  '"Sheet1"の比較位置
  lngRow1 = 1
  '"Sheet2"の比較位置
  lngRow2 = 1
  '"Sheet1"若しくは、"Sheet2"が最終行に達するまで繰り返し
  Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
    '比較結果に就いて
    Select Case vntData1(lngRow1, 1)
      Case Is = vntData2(lngRow2, 1) 'Matchiした場合
        '結果出力用配列に番号を代入
        vntResult(lngRow2, 1) = vntItems(lngRow1, 1)
        '両データの比較位置の更新
        lngRow1 = lngRow1 + 1
        lngRow2 = lngRow2 + 1
      Case Is > vntData2(lngRow2, 1) '"Sheet2"固有値の場合
        '結果出力用配列に記号を代入
        vntResult(lngRow2, 1) = cstrSign
        '"Sheet2"の比較位置を更新
        lngRow2 = lngRow2 + 1
      Case Is < vntData2(lngRow2, 1) '"Sheet1"固有値の場合
        '"Sheet1"の比較位置を更新
        lngRow1 = lngRow1 + 1
    End Select
  Loop
  
  '"Sheet2"に残ったデータを処理("Sheet2"固有値)
  For i = lngRow2 To lngEnd2
    '結果出力用配列に記号を代入
    vntResult(i, 1) = cstrSign
  Next i

  '結果を出力
  rngList2.Offset(1, 2).Resize(lngEnd2).Value = vntResult
  
  '"Sheet1"データの復旧
  DataRestore rngList1, lngEnd1, clngColumns1
  
  '"Sheet2"データの復旧
  DataRestore rngList2, lngEnd2, clngColumns2
  
  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList1 = Nothing
  Set rngList2 = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private Function GetBasicData(rngList As Range, _
                lngRows As Long, _
                lngColumns As Long, _
                lngKeys As Long, _
                vntData As Variant) As Boolean

  Dim i As Long
  Dim lngNumb() As Long
  
  '基準に就いて
  With rngList
    '行数を取得
    lngRows = .Offset(65536 - .Row, _
              lngKeys).End(xlUp).Row - .Row
    'データが無ければFunctionを抜ける(戻り値=False)
    If lngRows < 0 Then
      Exit Function
    End If
    '復帰用整列Keyを作成
    ReDim lngNumb(1 To lngRows, 1 To 1)
    For i = 1 To lngRows
      lngNumb(i, 1) = i
    Next i
    '復帰用Keyの出力列を挿入
    .Offset(1, lngColumns).EntireColumn.Insert
    '復帰用Keyの出力
    .Offset(1, lngColumns).Resize(lngRows).Value = lngNumb
    'データをlngKeys列で整列
    .Offset(1).Resize(lngRows, lngColumns + 1).Sort _
        Key1:=.Offset(1, lngKeys), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    'データを配列に取得
    vntData = .Offset(1, lngKeys).Resize(lngRows + 1).Value
  End With
  
  GetBasicData = True

End Function

Private Sub DataRestore(rngList As Range, _
            lngRows As Long, _
            lngColumns As Long)

  'データの復旧
  With rngList
    '元データ順位を復帰
    .Offset(1).Resize(lngRows, lngColumns + 1).Sort _
        Key1:=.Offset(1, lngColumns), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke

    '復帰用Key列を削除
    .Offset(, lngColumns).EntireColumn.Delete
  End With

End Sub

【41090】Re:お願いします。
回答  Kein  - 06/7/28(金) 21:50 -

引用なし
パスワード
   Sheet2 の一行目は項目であるとして・・

Sub Get_MyDataNum()
  With Sheets("Sheet2")
   With Range("D2", .Range("D65536").End(xlUp))
     .Formula = _
     "=INDIRECT(ADDRESS(MATCH($D2,Sheet1!$B:$B,0),1,3,TRUE,""Sheet1""))"
     .Copy
     .PasteSpecial xlPasteValues
   End With
   .Activate
   .Range("A1").Select
  End With
  Application.CutCopyMode = False
End Sub

>シート2の氏名がシート1の氏名になかったならば氏名がない事を
>シート2のC列に何かを記号を表記
見つからない場合は、#N/A というエラー値が表示されます。
もし他の表示にしたいなら、上記の数式を =IF(ISNA(数式),""表示値"",数式)
という形に変更するか

Sub Get_MyDataNum2()
  With Sheets("Sheet2")
   With Range("D2", .Range("D65536").End(xlUp))
     .Formula = _
     "=INDIRECT(ADDRESS(MATCH($D2,Sheet1!$B:$B,0),1,3,TRUE,""Sheet1""))"
     .Copy
     .PasteSpecial xlPasteValues
     On Error Resume Next
     .SpecialCells(2, 16).Value = "任意の表示値"
   End With
   On Error GoTo 0
   .Activate
   .Range("A1").Select
  End With
  Application.CutCopyMode = False
End Sub

と、エラー値のところだけ抽出して、任意の値に書き換えればよいでしょう。

【41091】Re:お願いします。
発言  Kein  - 06/7/28(金) 21:52 -

引用なし
パスワード
   訂正。
>With Range("D2", .Range("D65536").End(xlUp))


With .Range("D2", .Range("D65536").End(xlUp)).Offset(, -1)
  ↑ドットを追加                ↑これも追加

でした。ども。

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