いつもお世話になります、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

このQ&Aに関連する最新のQ&A

A 回答 (4件)

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
    • good
    • 0

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列にコピーしてきて欲しいのです。
取り急ぎではありますが以上何卒宜しくお願いいたします。

補足日時:2011/04/19 16:20
    • good
    • 0

>.[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

この回答への補足

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

補足日時:2011/04/19 15:02
    • good
    • 0

例えば。



変更前:
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)では「左端A列の」最下端しか調べることが出来ません。結果して上述「変更後」と同じ動作しかしていないという事です。
もしも最下端が「A列とは限らない」場合は,別の調べ方をする必要があります。
たとえばシート.cells.specialcells(xlcelltypelastcell)を調査するとか,BCDEFGH列を1列ずつ最下端を調べて一番大きい数字を採用するとか。
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!


人気Q&Aランキング