[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ﾏｸﾛにて対象物がない時に次の動作をさせる方法』（Takkr）
お世話になります。
自動作成ﾏｸﾛで集計ﾘｽﾄを作ったのですが、対象のものがなかった場合
次の動作に飛ぶ方法はどのようにすればよいかご教授願います。
以下作成例
Sheets("該当月ﾘｽﾄ").Select
ActiveSheet.Range("$A$1:$Z$572").AutoFilter Field:=3, Criteria1:="車両1"
ActiveSheet.Range("$A$1:$Z$572").AutoFilter Field:=7, Criteria1:=Array( _
"消耗品", "消耗品(品番有)", "補助材料", "補助材料(品番有)"), Operator:=xlFilterValues
Rows("2:572").Select
Selection.Copy
Sheets("車両1").Select
Rows("9:68").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("該当月ﾘｽﾄ").Select
ActiveSheet.Range("$A$1:$Z$572").AutoFilter Field:=7, Criteria1:="固定（特別）"
Rows("2:572").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("車両1").Select
Rows("73:132").Select
ActiveSheet.Paste
Range("A9").Select
Sheets("該当月ﾘｽﾄ").Select
ActiveSheet.Range("$A$1:$Z$572").AutoFilter Field:=7
ActiveSheet.Range("$A$1:$Z$572").AutoFilter Field:=3
Range("A2").Select
Sheets("該当月ﾘｽﾄ").Select
ActiveSheet.Range("$A$1:$Z$572").AutoFilter Field:=3, Criteria1:="車両2"
ActiveSheet.Range("$A$1:$Z$572").AutoFilter Field:=7, Criteria1:=Array( _
"消耗品", "消耗品(品番有)", "補助材料", "補助材料(品番有)"), Operator:=xlFilterValues
Rows("2:572").Select
Selection.Copy
Sheets("車両2").Select
Rows("9:68").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("該当月ﾘｽﾄ").Select
ActiveSheet.Range("$A$1:$Z$572").AutoFilter Field:=7, Criteria1:="固定（特別）"
Rows("2:572").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("車両2").Select
Rows("73:132").Select
ActiveSheet.Paste
Range("A9").Select
Sheets("該当月ﾘｽﾄ").Select
ActiveSheet.Range("$A$1:$Z$572").AutoFilter Field:=7
ActiveSheet.Range("$A$1:$Z$572").AutoFilter Field:=3
Range("A2").Select
該当月ﾘｽﾄに車両1ﾃﾞｰﾀｰが存在している時は作動するのですが
無い場合勝手に違うﾃﾞｰﾀをｺﾋﾟﾍﾟしていきます。
車両1でﾃﾞｰﾀｰがない時車両2へ移動させる方法はありませんか？
＜ 使用 Excel：Excel2013、使用 OS：Windows10 ＞
Sub 名無しのマクロ_整理()
Dim MyArr As Variant
MyArr = Array("消耗品", "消耗品(品番有)", "補助材料", "補助材料(品番有)")
With Sheets("該当月ﾘｽﾄ")
'▼オートフィルタの強制解除と設定
.AutoFilterMode = False
.Range("A1:Z1").AutoFilter
'▼抽出
.AutoFilter.Range.AutoFilter Field:=3, Criteria1:="車両1"
.AutoFilter.Range.AutoFilter Field:=7, Criteria1:=MyArr, Operator:=xlFilterValues
'▼データがあるかチェックしてデータがあったときだけコピペ
'// C列の最終行を調べたときに項目行である1だったら抽出されたものはない //
If .Cells(.Rows.Count, "C").End(xlUp).Row > 1 Then
.AutoFilter.Range.Offset(1).Copy '項目行を除いてコピー
Sheets("車両1").Range("A9").PasteSpecial Paste:=xlPasteValues
End If
'▼抽出
'.AutoFilter.Range.AutoFilter Field:=3, Criteria1:="車両1"
.AutoFilter.Range.AutoFilter Field:=7, Criteria1:="固定（特別）"
'▼データがあるかチェックしてデータがあったときだけコピペ
If .Cells(.Rows.Count, "C").End(xlUp).Row > 1 Then
.AutoFilter.Range.Offset(1).Copy '項目行を除いてコピー
Sheets("車両1").Range("A73").PasteSpecial Paste:=xlPasteValues
End If
'---ここから 車両2の分 ---
.AutoFilter.Range.AutoFilter Field:=3, Criteria1:="車両2"
.AutoFilter.Range.AutoFilter Field:=7, Criteria1:=MyArr, Operator:=xlFilterValues
If .Cells(.Rows.Count, "C").End(xlUp).Row > 1 Then
.AutoFilter.Range.Offset(1).Copy
Sheets("車両2").Range("A9").PasteSpecial Paste:=xlPasteValues
End If
.AutoFilter.Range.AutoFilter Field:=7, Criteria1:="固定（特別）"
If .Cells(.Rows.Count, "C").End(xlUp).Row > 1 Then
.AutoFilter.Range.Offset(1).Copy
Sheets("車両2").Range("A73").PasteSpecial Paste:=xlPasteValues
End If
'--- ここまで 車両2の分 ---
'▼オートフィルタは解除せずに抽出だけ解除
.ShowAllData
End With
End Sub
質問の「車両1でﾃﾞｰﾀｰがない時車両2へ移動させる方法はありませんか？」がちょっと理解できてませんが、「車両1」でデータがない場合【処理せず】、車両2の処理へ進むようにできませんか？」と解釈した場合、上記のように抽出した段階で最終行をチェックしてみてはどうでしょうか？
（もこな２） 2019/09/12(木) 09:03
Sub ループ処理()
Dim MyArr As Variant
Dim buf As Variant
MyArr = Array("消耗品", "消耗品(品番有)", "補助材料", "補助材料(品番有)")
With Sheets("該当月ﾘｽﾄ")
.AutoFilterMode = False
.Range("A1:Z1").AutoFilter
'▼ループ処理
For Each buf In Array("車両1", "車両2")
.AutoFilter.Range.AutoFilter Field:=3, Criteria1:=buf
.AutoFilter.Range.AutoFilter Field:=7, Criteria1:=MyArr, Operator:=xlFilterValues
If .Cells(.Rows.Count, "C").End(xlUp).Row > 1 Then
.AutoFilter.Range.Offset(1).Copy
Sheets(buf).Range("A9").PasteSpecial Paste:=xlPasteValues
End If
.AutoFilter.Range.AutoFilter Field:=7, Criteria1:="固定（特別）"
If .Cells(.Rows.Count, "C").End(xlUp).Row > 1 Then
.AutoFilter.Range.Offset(1).Copy
Sheets(buf).Range("A73").PasteSpecial Paste:=xlPasteValues
End If
Next buf
.ShowAllData
End With
End Sub
（もこな２） 2019/09/12(木) 09:10
ありがとうございます。
ﾏｸﾛ初心者の為、大変助かりました。
説明が要領を得ず、すみませんでした。
もこな２さんのご察しのとうりでございます。
早速試してみたいと思います。
（Takkr） 2019/09/12(木) 13:25
End If
.AutoFilter.Range.AutoFilter Field:=7, Criteria1:="固定（特別）"
If .Cells(.Rows.Count, "C").End(xlUp).Row > 1 Then
で="固定（特別）"は1項目だけなら検出するのですが、追加で"固定（定期）、"固定（共有
と増えていく場合
MyArr = Array("消耗品", "消耗品(品番有)", "補助材料", "補助材料(品番有)")
以外の複数を検出させるにはどのように表示させればよいのでしょうか。
同じように
Sub ループ処理()
Dim MyArr As Variant
Dim buf As Variant
MyArr = Array("固定（特別）", "固定（定期）", "固定（共有）")
と入れていくのが良いのでしょうか？
（Takkr） 2019/09/18(水) 09:26
下は、参考まで。動作確認してませんので、上手く結果が出なければごめんなさいです。
Sub test()
Const cKey材料費 As String = "消耗品,消耗品(品番有),補助材料,補助材料(品番有)"
Const ckey固定費 As String = "固定（特別）,固定（定期）"
Dim rngTable As Range
Dim rng固定 As Range
Dim rngデータ As Range
Dim ws As Worksheet
Dim wsList As Worksheet
Set wsList = Worksheets("該当月ﾘｽﾄ")
Set rngTable = wsList.Range("A1").CurrentRegion
Getデータセル Split(ckey固定費, ","), "", rngTable, rng固定
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> wsList.Name Then
If Getデータセル(ws.Name, Split(cKey材料費, ","), rngTable, rngデータ) Then
ws.UsedRange.ClearContents
urion(rngデータ, rng固定).Copy ws.Range("A1")
End If
End If
Next
End Sub
Function Getデータセル(ByVal sKeyWord1 As String, _
ByVal sKeyWord2 As String, _
ByRef rngTarget As Range, _
ByRef Rng As Range) As Boolean
With rngTarget
On Error Resume Next
.Worksheet.ShowAllData
On Error GoTo 0
.AutoFilter Field:=3, Criteria1:=sKeyWord1
.AutoFilter Field:=7, Criteria1:=sKeyWord2
If .Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
Getデータセル = True
Set Rng = .SpecialCells(xlCellTypeVisible)
End If
.AutoFilter
End With
End Function
（まっつわん） 2019/09/18(水) 10:15
早速の回答、誠にありがとうございます。
何か高度で難しいですね。検出したいのは"消耗品,消耗品(品番有),補助材料,補助材料(品番有)"だけで
それ以外は
If .Cells(.Rows.Count, "C").End(xlUp).Row > 1 Then
.AutoFilter.Range.Offset(1).Copy
Sheets(buf).Range("A73").PasteSpecial Paste:=xlPasteValues
End If
でA73に張付けたいのですが、あまり高度になると。。。。"（****）"とかの
代用で処理できれば
よのですが、とりあえず参考に修正掛けてみますが
他の方法が有れば教えてください。
なるべくなら、ﾏｸﾛの項目修正を都度しない方法を、選択したいのですが
無理ですかね。
（Takkr） 2019/09/18(水) 11:05
こちらとは同じじゃないんですかね
それはさておき
このようなケースであれば ・決まった別シートに抽出する ・選択条件がある程度固定 という点で オートフィルターよりフィルタオプションのほうがベターだと思いますが・・ マクロを使わなくてもできますし、 条件の修正も比較的簡単です。
（渡辺ひかる） 2019/09/18(水) 11:43
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.