[[20180430204411]]　『すべてのブックに対しての処理』（まさこ）　ページの最後に飛ぶ

『すべてのブックに対しての処理』（まさこ）

ブックAの原本シート

原本シートの以下のセルに貼り付けたい
V17　X17 　Z17　　←1個目をここに貼り付け
V18　X18 　Z18　　←2個目をここに貼り付け
V19　X19 　Z19　　←3個目をここに張り付け
V20　X20 　Z20　　←4個目をここに貼り付け

最大でも4つまでしかありません。

テストフォルダ以下のすべてのブック（レイアウトはすべて同じ）

AN2(AN2:AO2の結合セル) AQ2(AQ2:AR2の結合セル) AT2(AT2:AU2の結合セル)

平成　AN2　年　AQ2　月　AT2　日　　それぞれ３つのセルで日付となっています。

テストフォルダ以下のすべてのブックを順番に開いて、すべてのシートに対して　AN2　年　AQ2　月　AT2　日（この日付が、平成30年4月1日以降）
の場合のみ、原本シートにV17　X17 　Z17　にそれぞれ貼り付けたい。

原本シートに貼り付けた後に、開いたブックに対して、原本シートを一番右のシートに入れたいです。

これをテストフォルダ以下のすべてのブックに対して、行いたいです。

Sub 原本シートを一番右のシートに指し込み()

  Dim myPath As String
  Dim myFile As String

  myPath = "C:\テスト\"

  myFile = Dir(myPath & "*.xls*")
  Do Until myFile = ""

  Workbooks.Open myPath & myFile 
  Dim bk As Workbook
  Set bk = Workbooks("myPath & myFile")
  ActiveSheet.Copy _
  After:=bk.Sheets(bk.Sheets.Count)

  ActiveWorkbook.Close True
    myFile = Dir()
  Loop
 End Sub

ここまで頑張ってみましたが、出来ませんでした。
一回だけの作業ですが、数が多くて困っています。

＜使用 Excel：Excel2010、使用 OS：WindowsXP ＞

＞最大でも4つまでしかありません。

貼付け先は４つまでというのはわかりましたが
コピー元は、説明では１つなのでは？？

（マナ） 2018/04/30(月) 21:15

コピー元は、説明では１つなのでは？？
→テストフォルダ以下のすべてのブックを順番に開いて
そのブックには、シートが複数あり、各シートの平成　AN2　年　AQ2　月　AT2　日が
この日付が、平成30年4月1日以降の場合に、原本シートに記載したいです。

シート1 　平成　AN2　年　AQ2　月　AT2　日　
シート2　平成　AN2　年　AQ2　月　AT2　日
シート3　平成　AN2　年　AQ2　月　AT2　日
このような形です。
（まさこ） 2018/04/30(月) 22:04

テストフォルダ以下のすべてのブックを順番に開いて、
処理を行ってから、
原本シートをその都度、差し込み、保存が行いたいです☆
（まさこ） 2018/04/30(月) 22:08

理解しました。

では、シートのループやブックのループは後からにして

ますは、１つのブックの１つのシートから
そのシートの日付が、平成30年4月1日以降という前提で
転記する部分だけを考えてください。

（マナ） 2018/04/30(月) 22:17

 Dim d1 As Date
   　 d1 = "4/1/2018"

IF 　d1　 < DATE(AN2,AQ2,AT2)　　then

　　　　　Cells(2 , 40).Value=　Cells(17, 22).Value
　　　　　Cells(2 , 43).Value= Cells(19, 24).Value
　　　　　Cells(2 , 46).Value= Cells(21, 26).Value
こんな形だと思います。
（まさこ） 2018/04/30(月) 22:50

Dim ws As Worksheet
set ws = 原本シート
Dim d1 As Date

   　 d1 = "4/1/2018"
For Each a  In ThisWorkbook.Worksheets
IF   　d1　 <  DATE(AN2,AQ2,AT2)　　then

　　　　　a.Cells(2 , 40).Value=　ws.Cells(17, 22).Value
　　　　　a.Cells(2 , 43).Value= ws.Cells(19, 24).Value
　　　　　a.Cells(2 , 46).Value= ws.Cells(21, 26).Value
編集が分からないので、追加で記載します。このような形と思います。
（まさこ） 2018/04/30(月) 22:58

とりあえず動けばいいかと思い、以下のようにしてみました。
Dim ws As Worksheet
set ws = 原本シート
Dim d1 As Date

   　 d1 = "4/1/2018"
For Each a  In ThisWorkbook.Worksheets

IF 　d1　 < DATE(AN2,AQ2,AT2)　　then

   IF      ws.Cells(17, 22).Value="" then
          a.Cells(2 , 40).Value=　ws.Cells(17, 22).Value
　　　　　a.Cells(2 , 43).Value=  ws.Cells(17, 24).Value
　　　　　a.Cells(2 , 46).Value=  ws.Cells(17, 26).Value
   end if
   IF     ws.Cells(17, 22).Value<>"" and  ws.Cells(18, 22).Value=""
          a.Cells(2 , 40).Value=　ws.Cells(18, 22).Value
　　　　　a.Cells(2 , 43).Value=  ws.Cells(18, 24).Value
　　　　　a.Cells(2 , 46).Value=  ws.Cells(18, 26).Value
   end if
   IF      ws.Cells(17, 22).Value<>""= and  ws.Cells(18, 22).Value<>"" and  ws.Cells(19, 22).Value=""
          a.Cells(2 , 40).Value=　ws.Cells(19, 22).Value
　　　　　a.Cells(2 , 43).Value=  ws.Cells(19, 24).Value
　　　　　a.Cells(2 , 46).Value=  ws.Cells(19, 26).Value
   end if
   IF      ws.Cells(19, 22).Value<>""
　　　    a.Cells(2 , 40).Value=　ws.Cells(20, 22).Value
　　　　　a.Cells(2 , 43).Value=  ws.Cells(20, 24).Value
　　　　　a.Cells(2 , 46).Value=  ws.Cells(20, 26).Value
   end if
next a   
（まさこ） 2018/05/01(火) 00:01

 >Set bk = Workbooks("myPath & myFile")

 変数が文字列に成っちゃってますが・・・・。
 開いた後は、パスは必要ないです。
 Set bk = Workbooks(myFile)

 これですむんですけどね。

 Set bk = Workbooks.Open(myPath & myFile)
（BJ） 2018/05/01(火) 04:02

Sheet1のA1の値を、Sheet2のA1に転記するコードはわかりますか。

（マナ） 2018/05/01(火) 07:52

Sheets("Sheet1").Range("A1").Copy Destination:=Sheets("Sheet2").Range("A1")
です。
あっ、

 　ws.Cells(17, 22).Value = a.Cells(2 , 40).Value
反対でした汗。上記のようなコードです。
（まさこ） 2018/05/01(火) 19:07

BJ様　
Set bk = Workbooks("myPath & myFile")
確かにここでエラーがでていました。
ありがとうございます。
（まさこ） 2018/05/01(火) 19:33

おそらく、こんな流れでよいかと。

 １）ブックを開く
 ２）変数Nに17を代入
 ３）最初のシートの日付を調べ、4/1以降ならば
 ４）ブックAの原本シートのN行に転記
 ５）Nに１を加算
 ６）すべてのシートについて３～５）を繰り返す
 ７）N＞17ならば、原本シートをコピー
 ８）原本シートの転記先セルの値を消去
 ９）ブックを保存して閉じる
 10）以上をフォルダ内のすべてのブックについて繰り返す

次は、３）の日付判定部分について考えてください。

 ＞IF 　d1　 < DATE(AN2,AQ2,AT2)　　then

そんな使い方ありません、
Dateserialと間違えていませんか？

（マナ） 2018/05/01(火) 19:49

マナ様
Dateserialと間違えてますね。
CDate("平成" & a.Range("AN2").Value & "年" & a.Range("AQ2").Value & "月" & a.Range("AT2").Value & "日"), "YYYY/MM/DD")
もう少してみます。　メッセージでは上手く出来たのに構文ではエラーになってしまいます。
（まさこ） 2018/05/02(水) 07:31

＞Dateserialと間違えてますね。

ならば、Dateserialを使えばよいのでは？

（マナ） 2018/05/02(水) 10:08

Sub TEST()

  Dim Wb As Workbook
  Set Wb = Workbooks("BOOKA.xls")
  Dim ws As Worksheet
  Set ws = Wb.Worksheets("原本シート")

  Dim y As Long, m As Long, d As Long

  Dim myPath As String
  Dim myFile As String
  myPath = "C:\TEST\"
  myFile = Dir(myPath & "*.xls*")
  Do Until myFile = ""
  Workbooks.Open myPath & myFile

  Dim d1 As Date
  d1 = DateSerial(2018, 4, 1)
  Dim bk As Workbook
  Set bk = Workbooks(myFile)
For Each a In bk.Worksheets
  y = a.Range("AN2").Value
  m = a.Range("AQ2").Value
  d = a.Range("AT2").Value
  Dim d2 As Date
  d2 = DateSerial(y + 1988, m, d)
 If d1 < d2 Then

   If ws.Cells(17, 22).Value = "" Then
          ws.Cells(17, 22).Value = y
          ws.Cells(17, 24).Value = m
          ws.Cells(17, 26).Value = d
   End If

 End If
Next a

  ws.Copy _
  After:=bk.Sheets(bk.Sheets.Count)

   ws.Range("V17") = ""

   ws.ange("X17") = ""

   ws.Range("Z17") = ""

   ActiveWorkbook.Close True
    myFile = Dir()
  Loop
End Sub

日付の所が無理やりですが、クリアできました(^^)
2、4、7、8が上手く出来ませんが、上記のコードで、やっと思うように上手く動きました。
（まさこ） 2018/05/03(木) 01:04

＞2、4、7、8が上手く出来ませんが、

★の部分を参考にしてください

 Option Explicit

 Sub test()
    Dim ws As Worksheet
    Dim myPath As String
    Dim myFile As String
    Dim bk As Workbook
    Dim a As Worksheet
    Dim y As Long, m As Long, d As Long
    Dim d1 As Date
    Dim d2 As Date
    Dim n As Long

    Set ws = Workbooks("BOOKA.xls").Worksheets("原本シート")

    myPath = "C:\TEST\"
    myFile = Dir(myPath & "*.xls*")

    d1 = DateSerial(2018, 4, 1)

    Do Until myFile = ""
        Set bk = Workbooks.Open(myPath & myFile)

        n = 17   '★2

        For Each a In bk.Worksheets
            y = a.Range("AN2").Value
            m = a.Range("AQ2").Value
            d = a.Range("AT2").Value

            d2 = DateSerial(y + 1988, m, d)

            If d1 < d2 Then
                ws.Cells(n, 22).Value = y   '★4
                ws.Cells(n, 24).Value = m
                ws.Cells(n, 26).Value = d
                n = n + 1   '★5
                If n > 20 Then Exit For
            End If
        Next a
        If n > 17 Then   '★7
            ws.Copy After:=bk.Sheets(bk.Sheets.Count)
            ws.Range("V17:V20,X17:X20,Z17:Z20").ClearContents   '★8
        End If
        bk.Close True   '★9
        myFile = Dir()
  Loop

 End Sub

（マナ） 2018/05/03(木) 08:31

マナ様
せっかく流れを教えて頂いたのに、Nの所が出来ませんでした。教えて頂いたコードを参考にすると、理解出来ました。が、自分自身で書くとなると、難しかったです。
さっそく実務で使ってきました。完璧でした。時間はかかりましたが、ありがとうございました。
とても感謝しています。
（まさこ） 2018/05/03(木) 20:56

コメント返信：

[ 一覧(最新更新順) ]

[[20180430204411]] 『すべてのブックに対しての処理』（まさこ） ページの最後に飛ぶ

最大でも4つまでしかありません。

[[20180430204411]]　『すべてのブックに対しての処理』（まさこ）　ページの最後に飛ぶ