Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Professional : Excel 2010)
Match関数 照合結果の配列
投稿日時: 18/09/10 12:36:41
投稿者: KAZU_TABI

データファイルをSheet2に読込み、Sheet1の1行目データと照合しながら、一致するデータを
Sheet1の2行目以降に転記するマクロを作成しました。
現在のコードで正常に動きますが、Sheet1行目のデータに対して一致データが無い場合は
2行目以降を空欄にしたいです。
(Sheet1の1行目「条件」と2行目以降「結果」を一致させたい。)
 
修正方法が分かる方、お知恵をお貸しください。
 
【簡単な図解】
Sheet1<VBAシート名:データ入力>
1行目    A B Z C D E
2行目    A' B'   C' D' E'




 
Sheet2<VBAシート名:Sheet2>
1行目  A' B' C' E' D'




 
【コード】
Sub Sample1()
 
Dim buf As String, i As Long
Dim j
 
Application.ScreenUpdating = False
 
'***掃除***
Const strSagyouSheet As String = "sheet2"
ThisWorkbook.Worksheets(strSagyouSheet).Range("B1:Z5000").ClearContents
 
'***ファイル内データ貼付***
buf = Dir(Sheets("Sheet2").Range("A1").Value & "\*.*")
Do While buf <> ""
Workbooks.Open Worksheets("Sheet2").Range("A1").Value & "\" & buf
Sheets("GCSDD2R").Range("A1:Z20000").Copy
ThisWorkbook.Activate
Range("Z1").End(xlToLeft).Offset(0, 1).Select
ActiveSheet.Paste
Workbooks(buf).Activate
Application.CutCopyMode = False
Workbooks(buf).Close SaveChanges:=False
buf = Dir()
Loop
 
'選択行で検索
    Dim r1 As Range
    Dim r2 As Range
    Dim wsD As Worksheet
    Dim c As Range
    Dim n As Long
    Dim m
    Dim gyou As Range
     
    Sheets("データ入力").Range("B2:Z10000").Clear
     
     rc = MsgBox("Ascii_Data?" & vbCrLf & "Ascii=「はい」 Kic =「いいえ」 DTS =「キャンセル」", vbYesNoCancel + vbQuestion, "データ種類の確認")
     
    Select Case rc
        Case vbYes
            MsgBox "行数 = 4"
            Sheet2.Activate
            Range("A7").Value = "4"
        Case vbNo
            MsgBox "行数 = 2"
            Sheet2.Activate
            Range("A7").Value = "2"
        Case vbCancel
            MsgBox "行数 = 10"
                        Sheet2.Activate
            Range("A7").Value = "10"
        Case Else
            'ここには来ません。
    End Select
     
    Set gyou = Range("A7")
    Set r1 = Sheets("sheet2").Cells(1, 1).CurrentRegion.Rows(gyou)
    Set r2 = Sheets("データ入力").Cells(1, 1).CurrentRegion.Rows(1)
    Set wsD = Sheets("データ入力")
 
        n = 1
    For Each c In Intersect(r2, r2.Offset(, 1))
        m = Application.Match(c, r1, 0)
        If IsNumeric(m) Then
            n = n + 1
            wsD.Cells(2, n).Resize(31).Value = r1.Cells(1, m).Resize(31).Value 'データ入力シートの貼付開始2行目
            wsD.Cells(5000, n).Resize(15).Value = c.Resize(15).Value
        End If
    Next
 End Sub

回答
投稿日時: 18/09/10 15:24:41
投稿者: TAKA君

最後のIF文に
 
 Else
    n = n + 1
 End If
 
を足してみてはどうですか?
 

投稿日時: 18/09/10 15:36:45
投稿者: KAZU_TABI

ありがとうございます。
想像通りに動作しました。