[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数シートへのマクロ実行と複数範囲の転記』(わおん)
初めてこちらで質問させていただきます。
マクロ初心者で知識がなく、マクロの直し方がわかりません。
あるブック(日報のようなもの)の一部を違うブック(集計ブック)に転記をしようと思っています。
集計元は
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 >
.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
うーん…見当違いかもしれませんが(^^;
(虎) 2018/10/17(水) 14:53
(隠居じーさん) 2018/10/17(水) 14:55
ご回答ありがとうございます。
試したのですが、「変数が定義されていません」とエラーが出てしまいました…
(わおん) 2018/10/17(水) 15:03
コメントありがとうございます。
集計シートと同じフォルダに格納してあります。
ちなみに、集計元のブックは各拠点ごとになっているので
10個程フォーマットが同じブックが同フォルダにあります。
(わおん) 2018/10/17(水) 15:07
(隠居じーさん) 2018/10/17(水) 15:10
おっしゃる通りでございます。
(わおん) 2018/10/17(水) 15:12
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
私の変更は、元が各シートから1行しか代入していなかったものを、15行コピーするようにしただけです。 シート数分のループは、元々のものを使えば良いでしょう。
そもそも、元データのあるブックは何というファイル名ですか? Activeだと、マクロのあるブック自身になってしまうのでは? 虎さんのようにすると、自ブック内からコピーになってしまうし。
(???) 2018/10/17(水) 15:25
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
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
コメントありがとうございます。
うまく作動しない=エラーは出ないが拾わないブックがある
です。説明不足で申し訳ございません。
ブックに問題があるのかもしれないので
ひとつひとつチェックしています。
(わおん) 2018/10/18(木) 10:14
余計なことかもしれませんが
>ブックに問題があるのかもしれないのでひとつひとつチェックしています。
とのことでしたが、今回のようなミスであれば、「ステップ実行」しながらコードを追っていけば容易に見つかったんじゃないかとおもいます。
ですので、今後はご自身で「ステップ実行」しながら原因究明を試みることをオススメします。
また、ループのや条件分岐の入れ子になって逆に解りづらくなった感もありますが、こういう記述方法もありますよということで、サンプルコードを作成しましたので提供します。
興味があれば、「ステップ実行」してそれぞれの変数がどのように変わっていくのか、どのタイミングでどんな結果が出力されるのか研究してみてください。
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.