条件に応じて検索

いつも勉強させてもらってます。

－－コードSheet－－
【A列】【B列】　【C列】
　ID　　コード名　区分
D00034　ABCコード　未
D00035　DEFコード　新
D00036　GHIコード　変
D00037　JKLコード　変

－－業務Sheet－－
【A列】【B列】　【C列】
　ID　　進境具合　区分
D00035　かきくけこ　新
D00037　さしすせそ　新

－－チェックSheet－－
【A列】【B列】　【C列】　　　　　【D列】
　ID　　コード名　コードSheet区分　業務Sheet区分
－－－－－－－－－－－
コードSheetのC列の値が"未"以外の文字（新・変）なら
A列（ID)の値を業務Sheetで検索して、
チェックSheetに記入します。

業務SheetのIDはコードSheetに無い場合もあります。
その場合はチェックSheetには【A列】【B列】【D列】のみ記入します。

思いつくがままに下記のように作ったのですが、
案の定上手くいかず、途中で煮詰まってしまいました。
アドバイスお願いします。
Dim myRange As Range
Dim r As Long, i As Long
Dim AiRow As Variant, BiRow As Variant
Dim CiRow As Variant, DiRow As Variant, EiRow As Variant
r = 2
i = 2
AiRow = Worksheets("コード").Cells(r, 1).Value 'コードID
BiRow = Worksheets("コード").Cells(r, 3).Value 'コード区分
CiRow = Worksheets("業務シート").Cells(i,1).Value '業務ID
DiRow = Worksheets("業務シート").Cells(i,3).Value '業務区分

Worksheets("コード").Activate
For r = 2 To Range("C" & Rows.Count).End(xlUp).Row

If Not BiRow = "P" Then
myRange = .Find(what:=Range(AiRow))
Worksheets("チェック").Range("A" & i) = AiRow
～中略～
Worksheets("チェック").Range("D" & i) = DiRow
End If
Next

No.1 ベストアンサー 回答者： papayuka 回答日時： 2005/05/17 01:22

> 業務SheetのIDはコードSheetに無い場合もあります。

> その場合はチェックSheetには【A列】【B列】【D列】のみ記入します。

この意味が解りません。
チェックSheetのD列は業務Sheet区分ですよね？
コードSheetのIDを業務Sheetで検索して、無いのにどうやってD列を記入するのでしょう？

意味が解らないまま書いたので、違う可能性が大きいですが、、、

Sub Test()
Dim r As Range, tr As Range
Dim cdWs As Worksheet, gWs As Worksheet, chWs As Worksheet

Set cdWs = Worksheets("コード")
Set gWs = Worksheets("業務")
Set chWs = Worksheets("チェック")
For Each r In cdWs.Range("C2", cdWs.Range("C65536").End(xlUp))
　If r.Value <> "未" Then
　　 Set tr = chWs.Range("A65536").End(xlUp).Offset(1, 0)
　　 r.Offset(0, -2).Resize(1, 3).Copy Destination:=tr
　　 On Error Resume Next
　　 tr.Offset(0, 3).Value = _
　　 gWs.Range("C" & WorksheetFunction.Match(tr, gWs.Columns(1), 0)).Value
　End If
Next r

End Sub

この回答へのお礼

出来ました。
勉強になりました。有難うございました。

＞チェックSheetのD列は業務Sheet区分ですよね？
＞コードSheetのIDを業務Sheetで検索して、無いのにどうやってD列を記入するのでしょう？
本当ですね。C列の間違いですね。すいません。

お礼日時：2005/05/17 22:24

No.2 回答者： Wendy02 回答日時： 2005/05/17 02:44

私のコードは、最初にフィルタ・オプションで、必要なものを選り分けて、それを拾い出し、すべて配列の中に入れていきます。

次のシートもやはり、その配列を使って、該当する部分の場所に確保し、1度に、最後のシートで吐き出させてしまいます。

#－－チェックSheet－－
#【A列】【B列】　【C列】　　　　　【D列】
#　ID　　コード名　コードSheet区分　業務Sheet区分

4列ですから、配列の段階数は、4つ分にしました。しかし、配列の段階数の3段目は、Emptyでも、かならず4つのままにしてください。これは、レイアウトのためです。
なお、コードSheet区分を確保しても、何の支障もありません。

チェックシートは、貼り付けの前に、フィールドを残して、データは一旦削除されます。

難しいテクニックは1つも使われておりませんので、うまくない場合は、コードをたどって修正してください。

'標準モジュールに登録
Option Explicit
Sub MainCodeSheetPrc()
Dim MyCriteria As Range
Dim CodeShtRng As Range
Dim CodeArray() As Variant
Dim CodeShtArea As Range
Dim c As Range
Dim i As Long
Dim msgNum As Integer
'
With Worksheets("コード")
Set MyCriteria = .Range("AA1:AA2")
'Criteria の作成 '区分で 未でないもの'
MyCriteria = Application.Transpose(Array("区分", "<>未"))

Set CodeShtRng = .Range("A1", .Range("A65536").End(xlUp).Offset(, 2))
　Application.ScreenUpdating = False
CodeShtRng.AdvancedFilter _
　　　　　 Action:=xlFilterInPlace, _
　　　　　 CriteriaRange:= _
　　　　　 MyCriteria
'
　On Error GoTo ErrMsg
　　 Set CodeShtArea = CodeShtRng.Offset(1). _
　　　　　　　　　　　　Resize(CodeShtRng.Rows.Count - 1, 1). _
　　　　　　　　　　　　SpecialCells(xlCellTypeVisible)
　　 For Each c In CodeShtArea
　　　 ReDim Preserve CodeArray(3, i)
　　　 CodeArray(0, i) = c.Value　'コードID
　　　 CodeArray(1, i) = c.Offset(, 1).Value 'コード名
　　　'※不要
　　　 'CodeArray(2, i) = c.Offset(, 2).Value　'コード区分 ※
　　　 i = i + 1
　　 Next
　　 .ShowAllData
　End With
ErrMsg:
　Set CodeShtRng = Nothing: Set CodeShtArea = Nothing
　MyCriteria.ClearContents
　Application.ScreenUpdating = True
　If Err.Number > 0 Then
　　 MsgBox "コードシートには対象のコードが見つかりません。", 16
　　 Exit Sub
　End If
　On Error GoTo 0
　Call GyomuSheetPrc(CodeArray())
End Sub
'
Private Sub GyomuSheetPrc(CodeArray() As Variant)
Dim GyomuShtRng As Range
Dim i As Long
Dim rtn As Variant
With Worksheets("業務シート")
　Set GyomuShtRng = .Range("A1", .Range("A65536").End(xlUp))
　For i = LBound(CodeArray, 2) To UBound(CodeArray, 2)
　　　 rtn = Application.Match(CodeArray(0, i), GyomuShtRng, 0)
　　　 If Not IsError(rtn) Then
　　　　　CodeArray(3, i) = .Cells(rtn, 3).Value '業務区分
　　　　End If
　Next i
End With
Call CheckSheetPrc(CodeArray)
End Sub
'
Private Sub CheckSheetPrc(CodeArray() As Variant)
With Worksheets("チェック")
　 .Range("A2", .Range("A65536").End(xlUp)).Offset(, 3).ClearContents
　 .Range("A2").Resize(UBound(CodeArray, 2) + 1, 4).Value = _
　　　　　Application.Transpose(CodeArray) '貼り付け
　 .Select
End With
　 MsgBox "終了", 64
End Sub