マクロの条件を追加したいのですが

質問

いつもお世話になります、MEGUMIと申します。
既存のマクロに更に条件を追加したいという質問をさせてください。

現在、フォルダの中にある全てのエクセルファイルを下記のような処理をしています。
●エクセルファイルの中の全てのSheetの1行目以降のA,B,C,G,H列をコピーしてマクロを動作させるエクセルファイルのSheet1に順次（A,B,C,D,E列）ペースト
　※マクロは下記の内容（　Sub 今日のわたし()以降です　）です。

これに下記のような条件を追加したいのですがどのようにすればいいでしょうか？

○I列に”元気”という文字が存在していた場合に限って、その列のA,B,C,G,H,I列をコピーしてマクロを動作させるエクセルファイルのSheet1に順次（A,B,C,D,E,F列）ペースト

お忙しいところ大変恐れ入りますがもしご存知の方がいらっしゃりましたらご指導のほど何卒宜しくお願いいたします。

Sub 今日のわたし()
Dim XlFile As String
Dim MotoDataLastRow As Long
Dim CopySakiLastRow As Long

ThisWorkbook.Activate
Worksheets(1).Select
Cells.Clear

XlFile = Dir(ThisWorkbook.Path & "\*.xls?")
Do While XlFile <> ""
If XlFile <> ThisWorkbook.Name Then
Workbooks.Open ThisWorkbook.Path & "\" & XlFile, ReadOnly:=True
Worksheets(1).Select
MotoDataLastRow = Workbooks(XlFile).Worksheets(1).[A65536:H65536].End(xlUp).Row '元データファイルの最終行を取得
CopySakiLastRow = ThisWorkbook.Worksheets(1).[A65536:E65536].End(xlUp).Row 'インポート先の最終行を取得
If MotoDataLastRow > 1 Then
Range([A2], Cells(MotoDataLastRow, "C")).Copy ThisWorkbook.Worksheets(1).Cells(CopySakiLastRow + 1, "A")
Range([G2], Cells(MotoDataLastRow, "H")).Copy ThisWorkbook.Worksheets(1).Cells(CopySakiLastRow + 1, "D")
End If
Workbooks(XlFile).Close False
End If
XlFile = Dir()
Loop
End Sub

回答No.4

merlionXX · ベストアンサー

ANo2-3 merlionXXです。
どうもよくわかりません。

> ”元気”という文字のある列のA,B,C,G,H,IをコピーしてA,B,C,D,E,F列にコピーで問題ないです。

”元気”という文字のある列はI列ですよね？
そのI列になぜA,B,C,G,H列があるんですか？I列にはI列しかないでしょう？
”元気”という文字のある行のA,B,C,G,H,I列をコピーするんじゃないのですか？

> 現在の問題は
> ”元気”という文字がI列に入っていなくて別の文字が入っていてもコピーしてきてしまいます。

これはANo.2で回答したコードでの結果ではないのですか？
ANo3のコード、Sub 今日のわたし03()　では、”元気”という文字のある行だけ、A,B,C,G,H,I列をコピーするようにしたはずなのですが。
ひょっとしてエクセルのバージョンが違うとオートフィルタのコピーがうまくいかないのかもしれません。
可視セル（"元気"フィルターで抽出されたセル）だけコピーするように変えてみました。

これでどうでしょう？

Sub 今日のわたし04()
　　Dim XlFile As String
　　Dim MotoDataLastRow As Long
　　Dim CopySakiLastRow As Long
　　Dim myC As Range
　　ThisWorkbook.Activate
　　Worksheets(1).Select
　　Cells.Clear
　　Application.ScreenUpdating = False
　　XlFile = Dir(ThisWorkbook.Path & "\*.xls?")
　　Do While XlFile <> ""
　　　　If XlFile <> ThisWorkbook.Name Then
　　　　　　Workbooks.Open ThisWorkbook.Path & "\" & XlFile, ReadOnly:=True
　　　　　　With Worksheets(1)
　　　　　　　　Set myC = .Columns("I:I").Find(What:="元気", LookAt:=xlPart)
　　　　　　　　If Not myC Is Nothing Then
　　　　　　　　　　.AutoFilterMode = False
　　　　　　　　　　.Range("I:I").AutoFilter field:=1, Criteria1:="=*元気*"
　　　　　　　　　　MotoDataLastRow = Workbooks(XlFile).Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row '元データファイルのA列最終行を取得
　　　　　　　　　　CopySakiLastRow = ThisWorkbook.Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row 'インポート先のA列最終行を取得
　　　　　　　　　　.Range("A2", Cells(MotoDataLastRow, "C")).SpecialCells(xlCellTypeVisible).Copy ThisWorkbook.Worksheets(1).Cells(CopySakiLastRow + 1, "A")
　　　　　　　　　　.Range("G2", Cells(MotoDataLastRow, "I")).SpecialCells(xlCellTypeVisible).Copy ThisWorkbook.Worksheets(1).Cells(CopySakiLastRow + 1, "D")
　　　　　　　　End If
　　　　　　End With
　　　　　　Workbooks(XlFile).Close False
　　　　End If
　　　　XlFile = Dir()
　　Loop
　　Application.ScreenUpdating = True
End Sub

回答No.3

merlionXX

ANo2 merlionXXです。

違っているということは
、
> その列のA,B,C,G,H,I列をコピーして

ではなく、その行のA,B,C,G,H,I列をコピーするんですね？
ならば、これでいかがでしょう？

Sub 今日のわたし03()
　　Dim XlFile As String
　　Dim MotoDataLastRow As Long
　　Dim CopySakiLastRow As Long
　　Dim myC As Range
　　ThisWorkbook.Activate
　　Worksheets(1).Select
　　Cells.Clear
　　Application.ScreenUpdating = False
　　XlFile = Dir(ThisWorkbook.Path & "\*.xls?")
　　Do While XlFile <> ""
　　　　If XlFile <> ThisWorkbook.Name Then
　　　　　　Workbooks.Open ThisWorkbook.Path & "\" & XlFile, ReadOnly:=True
　　　　　　With Worksheets(1)
　　　　　　　　Set myC = .Columns("I:I").Find(What:="元気", LookAt:=xlPart)
　　　　　　　　If Not myC Is Nothing Then
　　　　　　　　　　.AutoFilterMode = False
　　　　　　　　　　.Range("I:I").AutoFilter field:=1, Criteria1:="=*元気*"
　　　　　　　　　　MotoDataLastRow = Workbooks(XlFile).Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row '元データファイルのA列最終行を取得
　　　　　　　　　　CopySakiLastRow = ThisWorkbook.Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row 'インポート先のA列最終行を取得
　　　　　　　　　　If MotoDataLastRow > 1 Then
　　　　　　　　　　　　.Range("A2", Cells(MotoDataLastRow, "C")).Copy ThisWorkbook.Worksheets(1).Cells(CopySakiLastRow + 1, "A")
　　　　　　　　　　　　.Range("G2", Cells(MotoDataLastRow, "I")).Copy ThisWorkbook.Worksheets(1).Cells(CopySakiLastRow + 1, "D")
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End With
　　　　　　Workbooks(XlFile).Close False
　　　　End If
　　　　XlFile = Dir()
　　Loop
　　Application.ScreenUpdating = True
End Sub

補足

申し訳ありません、私の説明不足でした。
”元気”という文字のある列のA,B,C,G,H,IをコピーしてA,B,C,D,E,F列にコピーで問題ないです。
現在の問題は
”元気”という文字がI列に入っていなくて別の文字が入っていてもコピーしてきてしまいます。
ちなみにI列に何も記載されていないとコピーはしてきません。
したいことは、
”元気”という文字がI列にあった場合にだけ、その列（”元気”がある列）のA,B,C,G,H,IをコピーしてA,B,C,D,E,F列にコピーしてきて欲しいのです。
取り急ぎではありますが以上何卒宜しくお願いいたします。

回答No.2

merlionXX

>.[A65536:H65536].End(xlUp).Row

このような書き方をはじめて見ましたが、どの列の最終行をもとめたいのでしょうか？
とりあえずA列で見ることにしました。

> ○I列に”元気”という文字が存在していた場合に限って、その列のA,B,C,G,H,I列をコピーしてマクロを動作させるエクセルファイルのSheet1に順次（A,B,C,D,E,F列）ペースト

元気という文字が存在しなければ何もしなくていいんですね？
では、一例です。

Sub 今日のわたし02()
　　Dim XlFile As String
　　Dim MotoDataLastRow As Long
　　Dim CopySakiLastRow As Long
　　Dim myC As Range
　　ThisWorkbook.Activate
　　Worksheets(1).Select
　　Cells.Clear
　　Application.ScreenUpdating = False
　　XlFile = Dir(ThisWorkbook.Path & "\*.xls?")
　　Do While XlFile <> ""
　　　　If XlFile <> ThisWorkbook.Name Then
　　　　　　Workbooks.Open ThisWorkbook.Path & "\" & XlFile, ReadOnly:=True
　　　　　　With Worksheets(1)
　　　　　　　　Set myC = .Columns("I:I").Find(What:="元気", LookAt:=xlPart)
　　　　　　　　If Not myC Is Nothing Then
　　　　　　　　　　MotoDataLastRow = Workbooks(XlFile).Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row '元データファイルのA列最終行を取得
　　　　　　　　　　CopySakiLastRow = ThisWorkbook.Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row 'インポート先のA列最終行を取得
　　　　　　　　　　If MotoDataLastRow > 1 Then
　　　　　　　　　　　　.Range("A2", Cells(MotoDataLastRow, "C")).Copy ThisWorkbook.Worksheets(1).Cells(CopySakiLastRow + 1, "A")
　　　　　　　　　　　　.Range("G2", Cells(MotoDataLastRow, "I")).Copy ThisWorkbook.Worksheets(1).Cells(CopySakiLastRow + 1, "D")
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End With
　　　　　　Workbooks(XlFile).Close False
　　　　End If
　　　　XlFile = Dir()
　　Loop
　　Application.ScreenUpdating = True
End Sub

補足

早速の返信ありがとうございました。
なぜか”元気”以外の文字が有るところも拾ってきてペーストされてしまうようです。
私の質問にもっとも近い出来なので何とか”元気”以外の文字を拾ってペーストしないようにしたいのですが・・・

回答No.1

keithin

例えば。

変更前：
Worksheets(1).Select
MotoDataLastRow = Workbooks(XlFile).Worksheets(1).[A65536:H65536].End(xlUp).Row '元データファイルの最終行を取得
CopySakiLastRow = ThisWorkbook.Worksheets(1).[A65536:E65536].End(xlUp).Row 'インポート先の最終行を取得

変更後：
Worksheets(1).Select
activesheet.autofiltermode = false
range("I:I").autofilter field:=1, criteria1:="=*元気*"
MotoDataLastRow = Workbooks(XlFile).Worksheets(1).range("A65536").End(xlUp).Row '元データファイルの最終行を取得
CopySakiLastRow = ThisWorkbook.Worksheets(1).range("A65536").End(xlUp).Row 'インポート先の最終行を取得

のように。

＃参考
今回ご質問内容には直接関係無い部分ですが，range("A65536:H65536").end(xlup)では「左端Ａ列の」最下端しか調べることが出来ません。結果して上述「変更後」と同じ動作しかしていないという事です。
もしも最下端が「Ａ列とは限らない」場合は，別の調べ方をする必要があります。
たとえばシート.cells.specialcells(xlcelltypelastcell)を調査するとか，ＢＣＤＥＦＧＨ列を１列ずつ最下端を調べて一番大きい数字を採用するとか。