[[20181017132327]] 『複数シートへのマクロ実行と複数範囲の転記』(わおん) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『複数シートへのマクロ実行と複数範囲の転記』(わおん)

初めてこちらで質問させていただきます。
マクロ初心者で知識がなく、マクロの直し方がわかりません。

あるブック(日報のようなもの)の一部を違うブック(集計ブック)に転記をしようと思っています。
集計元は
  C D E・・・Q
B20
B21




B34
までです。
シートは最大5シートです。

Option Explicit
Sub 転記()

Dim Sh As Worksheet

 For Each Sh In Worksheets

  Dim folderPath As String
  folderPath = ThisWorkbook.Path

  Dim objSheet As Worksheet
  Set objSheet = ActiveSheet

  Dim objFileName As String
  objFileName = objSheet.Parent.Name

  With ThisWorkbook.Worksheets("集計")
    Dim tgtRow As Integer
    tgtRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1

    .Range("A" & tgtRow).Value = objSheet.Range("B20:B34").Value '日付
    .Range("B" & tgtRow).Value = objSheet.Range("P1").Value      '所属
    .Range("C" & tgtRow).Value = objSheet.Range("C20:C34").Value '企業
    .Range("D" & tgtRow).Value = objSheet.Range("F20:F34").Value '役職
    .Range("E" & tgtRow).Value = objSheet.Range("G20:G34").Value '氏名
    .Range("F" & tgtRow).Value = objSheet.Range("I20:I34").Value '担当
    .Range("G" & tgtRow).Value = objSheet.Range("J20:J34").Value '同行者
    .Range("H" & tgtRow).Value = objSheet.Range("K20:K34").Value '進捗
    .Range("I" & tgtRow).Value = objSheet.Range("M20:M34").Value '商談内容
    .Range("J" & tgtRow).Value = objSheet.Range("P20:P34").Value '頻度
    .Range("K" & tgtRow).Value = objSheet.Range("Q20:Q34").Value '次回
End With
Next
End Sub

マクロのエラーは出ないのですが、開いたシートの1行目(B21〜Q21)が集計シートに5行連続で入ってしまいます。
無知なもので、どこが間違っているかわかりません。
皆様のお力添えをお願いいたします。

< 使用 Excel:Excel2010、使用 OS:Windows7 >


シートが最大5シート、というのがどの部分の事なのか判りませんが、とりあえずは、以下のどちらかのように書いて、代入先も15行用意してみてください。
        .Range("A" & tgtRow & ":A" & tgtRow + 14).Value = objsheet.Range("B20:B34").Value

        .Range("A" & tgtRow).Resize(15, 1).Value = objsheet.Range("B20:B34").Value
(???) 2018/10/17(水) 14:12

(???)様

早々のご回答ありがとうございます。
上記の方法で試してみたところ、同じ内容が5回連続で反映されてしまいます。

     C  D  E  F…
B20 あ い う え…
B21 ア イ ウ エ…
B22
B23
・
・
B34

集計シートに反映させると↓
 B C D E・・・
A2あ い う え…
A3ア イ ウ エ…
A4あ い う え…
A5ア イ ウ エ…
A6あ い う え…
A7ア イ ウ エ…


のような感じになります。

説明が下手で申し訳ないのですが、改善策はあるのでしょうか?
ちなみに、5つのシートは集計元のシート(日報のような)が5シートあるということです。
フォーマットはすべて一緒です。
(わおん) 2018/10/17(水) 14:27


???さんの方法で、
objsheet.Range("B20:B34").Value
のobjsheetをShに変えてみたらどうでしょうか?

うーん…見当違いかもしれませんが(^^;

(虎) 2018/10/17(水) 14:53


あの〜 ^^;
あるブック(日報のようなもの)って。。。どこにあるのでしょうか。

(隠居じーさん) 2018/10/17(水) 14:55


(虎)様

ご回答ありがとうございます。
試したのですが、「変数が定義されていません」とエラーが出てしまいました…
(わおん) 2018/10/17(水) 15:03


(隠居じーさん)様

コメントありがとうございます。
集計シートと同じフォルダに格納してあります。
ちなみに、集計元のブックは各拠点ごとになっているので
10個程フォーマットが同じブックが同フォルダにあります。
(わおん) 2018/10/17(水) 15:07


あ。。はい。。。既に手動で開いていてそのBOOKのシートがアクティブシート
という理解でよいのでしょうか。

(隠居じーさん) 2018/10/17(水) 15:10


(隠居じーさん)様

おっしゃる通りでございます。
(わおん) 2018/10/17(水) 15:12


今の状況は???様のマクロを取り入れ、
For〜Nextを削除したマクロです。
集計シートに連続で入力されることが改善されましたが、
全シートにマクロを反映させることができません。。。

Option Explicit
Sub 転記()

  Dim folderPath As String
  folderPath = ThisWorkbook.Path

  Dim objSheet As Worksheet
  Set objSheet = ActiveSheet

  Dim objFileName As String
  objFileName = objSheet.Parent.Name

  With ThisWorkbook.Worksheets("集計")
    Dim tgtRow As Integer
    tgtRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1

    .Range("A" & tgtRow & ":A" & tgtRow + 14).Value = objSheet.Range("B20:B34").Value '日付
    .Range("B" & tgtRow & ":B" & tgtRow + 14).Value = objSheet.Range("A20:A34").Value '営業所
    .Range("C" & tgtRow & ":C" & tgtRow + 14).Value = objSheet.Range("C20:C34").Value '企業
    .Range("D" & tgtRow & ":D" & tgtRow + 14).Value = objSheet.Range("F20:F34").Value '役職
    .Range("E" & tgtRow & ":E" & tgtRow + 14).Value = objSheet.Range("G20:G34").Value '氏名
    .Range("F" & tgtRow & ":F" & tgtRow + 14).Value = objSheet.Range("I20:I34").Value '担当
    .Range("G" & tgtRow & ":G" & tgtRow + 14).Value = objSheet.Range("J20:J34").Value '同行者
    .Range("H" & tgtRow & ":H" & tgtRow + 14).Value = objSheet.Range("K20:K34").Value '進捗
    .Range("I" & tgtRow & ":I" & tgtRow + 14).Value = objSheet.Range("M20:M34").Value '内容
    .Range("J" & tgtRow & ":J" & tgtRow + 14).Value = objSheet.Range("P20:B34").Value '頻度
    .Range("K" & tgtRow & ":K" & tgtRow + 14).Value = objSheet.Range("Q20:Q34").Value '次回

End With

End Sub

以上が今のマクロです
(わおん) 2018/10/17(水) 15:17


こちらで試したときは、「変数が定義されていません」とはなりませんでしたが…(^^;
とりあえず、こんな感じで動きませんでしょうか?

Sub 転記()

    Dim Sh As Worksheet

    For Each Sh In Worksheets
      With ThisWorkbook.Worksheets("集計")
        Dim tgtRow As Long
        tgtRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Range("A" & tgtRow).Resize(15, 1).Value = Sh.Range("B20:B34").Value '日付
        .Range("B" & tgtRow).Resize(15, 1).Value = Sh.Range("P1").Value      '所属
        .Range("C" & tgtRow).Resize(15, 1).Value = Sh.Range("C20:C34").Value '企業
        .Range("D" & tgtRow).Resize(15, 1).Value = Sh.Range("F20:F34").Value '役職
        .Range("E" & tgtRow).Resize(15, 1).Value = Sh.Range("G20:G34").Value '氏名
        .Range("F" & tgtRow).Resize(15, 1).Value = Sh.Range("I20:I34").Value '担当
        .Range("G" & tgtRow).Resize(15, 1).Value = Sh.Range("J20:J34").Value '同行者
        .Range("H" & tgtRow).Resize(15, 1).Value = Sh.Range("K20:K34").Value '進捗
        .Range("I" & tgtRow).Resize(15, 1).Value = Sh.Range("M20:M34").Value '商談内容
        .Range("J" & tgtRow).Resize(15, 1).Value = Sh.Range("P20:P34").Value '頻度
        .Range("K" & tgtRow).Resize(15, 1).Value = Sh.Range("Q20:Q34").Value '次回
    End With
    Next Sh

End Sub

(虎) 2018/10/17(水) 15:21


For 〜 Next 部分を消すと、シート数分ループしなくなりますよ? 1シート分しか処理しなくなって当たり前です。

私の変更は、元が各シートから1行しか代入していなかったものを、15行コピーするようにしただけです。 シート数分のループは、元々のものを使えば良いでしょう。

そもそも、元データのあるブックは何というファイル名ですか? Activeだと、マクロのあるブック自身になってしまうのでは? 虎さんのようにすると、自ブック内からコピーになってしまうし。
(???) 2018/10/17(水) 15:25


(虎)様
私のやり方が間違っていたのだと思います、すみません。。。
上記のマクロで作動しました!
ありがとうございます。
(わおん) 2018/10/17(水) 15:32

(???)様
無知なもので、申し訳ないです。。。
元のブック名は「営業週報_○○営業所201811」です。
作業を始めた当初は、フォルダ内の上記のブックをまとめて集計
したかったのですが、知識がない私には無理そうなので、
ブックを1つ1つ集計することにしました。
(わおん) 2018/10/17(水) 15:35

あれ、ブック名指定なしでも正しく動きました? とりあえず、該当ブックを同じExcelで予め開いておいてから実行する例なぞ。

 Sub 転記()
    Dim Sh As Worksheet
    Dim tgtRow As Long

    With ThisWorkbook.Worksheets("集計")
        For Each Sh In Workbooks("営業週報_○○営業所201811.xlsx").Worksheets
            tgtRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1

            .Range("A" & tgtRow).Resize(15, 1).Value = Sh.Range("B20:B34").Value '日付
            .Range("B" & tgtRow).Resize(15, 1).Value = Sh.Range("P1").Value      '所属
            .Range("C" & tgtRow).Resize(15, 1).Value = Sh.Range("C20:C34").Value '企業
            .Range("D" & tgtRow).Resize(15, 1).Value = Sh.Range("F20:F34").Value '役職
            .Range("E" & tgtRow).Resize(15, 1).Value = Sh.Range("G20:G34").Value '氏名
            .Range("F" & tgtRow).Resize(15, 1).Value = Sh.Range("I20:I34").Value '担当
            .Range("G" & tgtRow).Resize(15, 1).Value = Sh.Range("J20:J34").Value '同行者
            .Range("H" & tgtRow).Resize(15, 1).Value = Sh.Range("K20:K34").Value '進捗
            .Range("I" & tgtRow).Resize(15, 1).Value = Sh.Range("M20:M34").Value '商談内容
            .Range("J" & tgtRow).Resize(15, 1).Value = Sh.Range("P20:P34").Value '頻度
            .Range("K" & tgtRow).Resize(15, 1).Value = Sh.Range("Q20:Q34").Value '次回
        Next Sh
    End With
 End Sub

あとはFor Eachしている外で、Dir関数で見つかるファイル名が無くなるまでループしてブックを開くようにでも変えれば、全ブックからの転記も書けると思います。
(???) 2018/10/17(水) 15:41


???様
上記のマクロでも作動しました、ありがとうございます。
図々しいお願いで申し訳ないのですが、
Dir関数を使う場合はどういうマクロになりますか?
お手すきの際にご回答いただければ幸いです。
(わおん) 2018/10/17(水) 15:50

私がさらっと書いても、多分そのまま動いてしまうので、まずはご自身で考えて欲しかったのですが。 1ブック1シートしか試していませんが、こんな感じと思います。
 Sub 転記()
    Const cPATH = "c:\tmp\test\"
    Dim wk As Workbook
    Dim Sh As Worksheet
    Dim tgtRow As Long
    Dim cFile As String

    Application.ScreenUpdating = False

    With ThisWorkbook.Worksheets("集計")
        cFile = Dir(cPATH & "*.xlsx")
        While cFile <> ""
            Set wk = Workbooks.Open(cPATH & cFile, False, True)
            For Each Sh In wk.Worksheets
                tgtRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
                .Range("A" & tgtRow).Resize(15, 1).Value = Sh.Range("B20:B34").Value '日付
                .Range("B" & tgtRow).Resize(15, 1).Value = Sh.Range("P1").Value      '所属
                .Range("C" & tgtRow).Resize(15, 1).Value = Sh.Range("C20:C34").Value '企業
                .Range("D" & tgtRow).Resize(15, 1).Value = Sh.Range("F20:F34").Value '役職
                .Range("E" & tgtRow).Resize(15, 1).Value = Sh.Range("G20:G34").Value '氏名
                .Range("F" & tgtRow).Resize(15, 1).Value = Sh.Range("I20:I34").Value '担当
                .Range("G" & tgtRow).Resize(15, 1).Value = Sh.Range("J20:J34").Value '同行者
                .Range("H" & tgtRow).Resize(15, 1).Value = Sh.Range("K20:K34").Value '進捗
                .Range("I" & tgtRow).Resize(15, 1).Value = Sh.Range("M20:M34").Value '商談内容
                .Range("J" & tgtRow).Resize(15, 1).Value = Sh.Range("P20:P34").Value '頻度
                .Range("K" & tgtRow).Resize(15, 1).Value = Sh.Range("Q20:Q34").Value '次回
            Next Sh
            wk.Close False
            cFile = Dir
        Wend
    End With

    Application.ScreenUpdating = True
 End Sub

この方法の場合、対象ブックはマクロ内で開くので、予め全て閉じておいてください。
(???) 2018/10/17(水) 16:33


???様

調べてみたのですが、なかなか作動せずお伺いしました。。。
ご丁寧にご回答いただき、本当にありがとうございます。

うまく作動しないのですが、試行錯誤試してみます。
ありがとうございました!
(わおん) 2018/10/17(水) 16:53


横から失礼します。

>うまく作動しないのですが、
テストはしてないですが、さらっと見た感じ動くような気がしますけど、なにがどう”うまく動かない”ですか_?

エラーが発生するなら、ステップ実行してみてどこがおかしいのか、まずは自力でチェックしてみてはどうでしょうか?

ちなみに、個人的には

 cFile = Dir(cPATH & "*.xlsx") 
   ↓
 cFile = Dir(cPATH & "*.xls?")

のように「xls」 や 「xlsm」にも対応できるよう変更することと、

>集計シートと同じフォルダに格納してあります。
(多分集計”ブック”と同じフォルダの書き間違い)とのことなので、

 While cFile <> ""
   IF not cFile = ThisWorkbook.Name Then
           〜 処理 〜
   End IF
   cFile = Dir
 Wend

のように、自ブックの名前と一致するなら処理から外すようにします。

(もこな2) 2018/10/17(水) 20:58


(もこな2)様

コメントありがとうございます。
うまく作動しない=エラーは出ないが拾わないブックがある
です。説明不足で申し訳ございません。

ブックに問題があるのかもしれないので
ひとつひとつチェックしています。

(わおん) 2018/10/18(木) 10:14


cFile = Dirを2重に記入していました。
削除したところ、すべて正常に作動いたしました。
皆様、本当にありがとうございます。
(わおん) 2018/10/18(木) 11:06

ご自身で直すことができたのであれば何よりです。

余計なことかもしれませんが
>ブックに問題があるのかもしれないのでひとつひとつチェックしています。
とのことでしたが、今回のようなミスであれば、「ステップ実行」しながらコードを追っていけば容易に見つかったんじゃないかとおもいます。

ですので、今後はご自身で「ステップ実行」しながら原因究明を試みることをオススメします。

また、ループのや条件分岐の入れ子になって逆に解りづらくなった感もありますが、こういう記述方法もありますよということで、サンプルコードを作成しましたので提供します。
興味があれば、「ステップ実行」してそれぞれの変数がどのように変わっていくのか、どのタイミングでどんな結果が出力されるのか研究してみてください。

    Sub 研究用()
        Dim ブック名 As String
        Dim i As Long
        Dim srcSH As Worksheet
        Dim dstSH As Worksheet: Set dstSH = ThisWorkbook.Worksheets("集計")
        Dim MyArr As Variant

        Stop

        '配列に列文字を格納
        '日付、所属、企業、役職、氏名、担当、同行者、進捗、商談内容、頻度、次回
        MyArr = Array("B", "P", "C", "F", "G", "I", "J", "K", "M", "P", "Q")

        'Dir関数で自ブックが保存されているフォルダ内のエクセルブックを片っ端から取得
        ブック名 = Dir(ThisWorkbook.Path & "\*.xls?")

        'ブック名に"空白"が格納されるまでループ処理
        Do Until ブック名 = ""

            '自ブックは処理対象外
            If Not ブック名 = ThisWorkbook.Name Then

                '処理対象ブックを開いて
                With Workbooks.Open(ThisWorkbook.Path & "\" & ブック名)

                    '「処理対象ブック」の全シートを順番に処理
                    For Each srcSH In .Worksheets

                        '対象シートのA列最終行+1を基準に
                        With dstSH.Cells(dstSH.Rows.Count, "A").End(xlUp).Offset(1)

                            '基準のセルから何個右にずれるのかで書き込む(行と)列を指定
                            For i = 0 To UBound(MyArr) Step 1

                                'コピー元がP列の場合以外は、同じ処理で良い
                                If MyArr(i) = "P" Then
                                    .Offset(, i).Resize(15).Value = srcSH.Range("P1").Value
                                Else
                                    .Offset(, i).Resize(15).Value = srcSH.Cells(20, MyArr(i)).Resize(15).Value
                                End If
                            Next i

                            'オマケ(L列、M列にどのブック、シートから持ってきたデータなのかを記入)
                            dstSH.Cells(.Row, "L").Resize(15).Value = srcSH.Parent.Name
                            dstSH.Cells(.Row, "M").Resize(15).Value = srcSH.Name

                        End With

                    Next srcSH

                    '「処理対象ブック」を閉じる
                    .Close

                End With
            End If

            '「ブック名」に次のブック名を代入する
            ブック名 = Dir()

        Loop

     End Sub

(もこな2) 2018/10/18(木) 17:09


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.