[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBAコードを書き換えたい』(おでん)
複数ファイルのExcelデータを一つのシート上に集約したく、
下記のコードを別の人に作成してもらいました。
同じフォーマットで入力された複数のファイルの、
特定の列の値を抽出して、別ファイルの1シート上に集約していくというものです。
下記コードで問題なく動作したんですが、
この度抜き出す列を増やす必要が出まして、
【元々動作したもの】tbl = Array("D", "W", "X", "Y", "Z")
【増やしたもの】tbl = Array("E", "F", "K", "L", "M", "N", "X", "Y", "Z", "AA", "AB")
で書き換えてみたんですが、M以降の列が抜き出されません。
その他、どの部分を書き換える必要があるのでしょうか。
下記、いただいたコードです。
Sub 集計()
Dim fpath As String
Dim fname As String
Dim wb As Workbook
Dim sh1 As Worksheet, sh2 As Worksheet
Dim r1 As Long, r2 As Long
Dim sr As Long, tr As Long
Dim tbl As Variant
Dim i As Integer
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = False Then Exit Sub
fpath = .SelectedItems(1) & "\"
End With
Application.ScreenUpdating = False
tbl = Array("D", "W", "X", "Y", "Z")
Set sh1 = ThisWorkbook.Worksheets("Sheet1")
sr = 4
fname = Dir(fpath & "*.xls", vbNormal)
Do Until fname = ""
Set wb = Workbooks.Open(fpath & fname)
Set sh2 = wb.Worksheets("Sheet1")
With sh2
sh1.Range("B" & sr) = .Range("J2")
tr = 0
For i = 0 To 4
r2 = sr - 1
For r1 = 6 To .Cells(Rows.Count, tbl(i)).End(xlUp).Row
If .Range(tbl(i) & r1) <> "" Then
r2 = r2 + 1
sh1.Cells(r2, i + 3) = .Range(tbl(i) & r1)
If r2 > tr Then
tr = r2
End If
End If
Next r1
Next i
sr = tr + 1
End With
wb.Close
fname = Dir()
Loop
Application.ScreenUpdating = True
End Sub
< 使用 Excel:Excel2016、使用 OS:Windows10 >
まずはコードを理解する必要があります。 そのためには、きちんとインデントを付けて コードの構造がわかるようなものにする必要があります。 今のものはお経のようで、とても分かりにくいですね。 ↓をながめると理解し易くなりませんか?
Sub 集計() Dim fpath As String Dim fname As String Dim wb As Workbook Dim sh1 As Worksheet, sh2 As Worksheet Dim r1 As Long, r2 As Long Dim sr As Long, tr As Long Dim tbl As Variant Dim i As Integer With Application.FileDialog(msoFileDialogFolderPicker) If .Show = False Then Exit Sub fpath = .SelectedItems(1) & "\" End With Application.ScreenUpdating = False tbl = Array("D", "W", "X", "Y", "Z") Set sh1 = ThisWorkbook.Worksheets("Sheet1") sr = 4 fname = Dir(fpath & "*.xls", vbNormal) Do Until fname = "" Set wb = Workbooks.Open(fpath & fname) Set sh2 = wb.Worksheets("Sheet1") With sh2 sh1.Range("B" & sr) = .Range("J2") tr = 0 For i = 0 To 4 r2 = sr - 1 For r1 = 6 To .Cells(Rows.Count, tbl(i)).End(xlUp).Row If .Range(tbl(i) & r1) <> "" Then r2 = r2 + 1 sh1.Cells(r2, i + 3) = .Range(tbl(i) & r1) If r2 > tr Then tr = r2 End If End If Next r1 Next i sr = tr + 1 End With wb.Close fname = Dir() Loop Application.ScreenUpdating = True End Sub 気が付きませんか?
(γ) 2020/07/31(金) 14:20
まず質問側の知識がまったく伴っていないことを痛感しましたので、
勉強してみて、改めて質問をさせていただきます。
インデントしていただいたなか、大変申し訳有りません。
ただ、こちらのインデントをヒントに、まずコードを理解できるよう努めてみます。
ありがとうございます。
(おでん) 2020/07/31(金) 14:48
さて、貴方は何処を変えたでしょう? 他にも変えるところは無いですか?
足りないのは知識ではなく発想であり、気付くまで何度も試す根気です。
(???) 2020/07/31(金) 14:55
【変更前】For i = 0 To 4
【変更後】For i = 0 To 11
とするといいのでしょうか?
そうしたところ、下記の部分にエラーが出たようで、黄色いマーカーが引かれてしまいました…
(実行時エラー9、インデックスが有効範囲ではありません、と表示されました)
For r1 = 6 To .Cells(Rows.Count, tbl(i)).End(xlUp).Row
こちらは抽出元のExcelファイルの6行目から抜き出すという内容かと思うのですが、
その部分に対しては変更はないはずなのですが、どこがおかしかったのでしょうか?
(おでん) 2020/07/31(金) 15:32
さらに、ひとつ減らすとよいのでは? ^^; 多分12項目になっているかと。0 〜 11 (隠居じーさん) 2020/07/31(金) 15:48
0 1 2 3 4 "D", "W", "X", "Y", "Z"
0 1 2 3 4 5 6 7 8 9 10 "E", "F", "K", "L", "M", "N", "X", "Y", "Z", "AA", "AB" 0 To 11だと数があっていない。 (ねむねむ) 2020/07/31(金) 15:52
ちなみに、知識があれば、より良い方法があります。ループの最大数を UBound(tbl) としてみてください。
(???) 2020/07/31(金) 15:55
Ubound(tbl)にして、エラーなくできるようになりました!
配列を最後までループするというものなんですね。
ただ、問題が発生してしまいまして、
抽出したデータなんですが、
1〜6行目は問題なくできたのですが、
7〜27行目になると、セルが一つ右へズレて抽出されてしまいます。
その後、
28〜34行目になると、また問題なく正常に抽出され、
35行目からまたセルが一つ右へ…
となってしまいます。
6行が正常に動作し、その後20行は一つ右へズレて抽出され、その後はまた6行が正常・・・
という6行ごとになんらかがループになっているみたいです。
これは何が起こっているでしょうか・・・
【現状コード下記です。】
Sub test()
Dim fpath As String
Dim fname As String
Dim wb As Workbook
Dim sh1 As Worksheet, sh2 As Worksheet
Dim r1 As Long, r2 As Long
Dim sr As Long, tr As Long
Dim tbl As Variant
Dim i As Integer
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = False Then Exit Sub
fpath = .SelectedItems(1) & "\"
End With
Application.ScreenUpdating = False
tbl = Array("E", "F", "K", "L", "M", "N", "X", "Y", "Z", "AA", "AB")
Set sh1 = ThisWorkbook.Worksheets("Sheet1")
sr = 4
fname = Dir(fpath & "*.xls", vbNormal)
Do Until fname = ""
Set wb = Workbooks.Open(fpath & fname)
Set sh2 = wb.Worksheets("Sheet1")
With sh2
sh1.Range("B" & sr) = .Range("K2")
tr = 0
For i = 0 To UBound(tbl)
r2 = sr - 1
For r1 = 6 To .Cells(Rows.Count, tbl(i)).End(xlUp).Row
If .Range(tbl(i) & r1) <> "" Then
r2 = r2 + 1
sh1.Cells(r2, i + 3) = .Range(tbl(i) & r1)
If r2 > tr Then
tr = r2
End If
End If
Next r1
Next i
sr = tr + 1
End With
wb.Close
fname = Dir()
Loop
Application.ScreenUpdating = True
End Sub
根気のない質問で申し訳ないです。
(おでん) 2020/07/31(金) 16:25
思った通りに動かないなら、ローカルウィンドウでも表示しておいてからステップ実行して、変数の内容が思った通りか確認してみてください。 実際のデータがないと、回答者側では調べる事はできませんからね。
If文で空欄判定しているようだし、途中空欄が引き金になっていませんか?
デバッグは時間のかかる作業です。 慣れてないなら、これくらいのコードなら、1週間くらいかかってもおかしくありませんよ。 1時間くらいで音を上げないように。
(???) 2020/07/31(金) 17:12
時間をかけてやってみます。
(おでん) 2020/07/31(金) 17:20
■1
既にコメントがあるとおり、コードを改造するなら、まず元のコードを理解することが先決だと思います。
それには、ステップ実行という方法で1行ずつコードを実行して、変数がどのように変わっているのか確認したり、命令の結果どのような処理がされるのか観察するというアプローチが非常に有効だとおもいますので、方法を紹介します。
●「ステップ実行」とは https://www.239-programing.com/excel-vba/basic/basic023.html http://plus1excel.web.fc2.com/learning/l301/t405.html
また、「ブレークポイント」についても気になるかもしれませんから、そちらも紹介します。
●「ブレークポイント」とは https://www.tipsfound.com/vba/01010 https://www.moug.net/tech/exvba/0150019.html
■2
さて、インデントについて既に言及されていますが、ご自身としては無い方が見やすいですか?
[[20180220104908]] 『ループの書き方』(ゆう)
↑の方のように強いこだわりがあり、どうしてもインデントを付けたくないのであれば仕方がありませんが、一般的にはインデントをつけて、コードを読みやすくするというアプローチはよく採られる手法ですので、こだわりがなければインデントをつけたほうがよいとおもいます。
■3
今回は配列について、0から始まっていて、UBoundで(添え字の)最大数を確認できると教わってます。
しかし、(今回は違いますが)1から始まるパターンもありますので、最"小"値を求める方法もセットとして覚えておくと良いと思います。
http://officetanaka.net/excel/vba/function/UBound.htm
http://officetanaka.net/excel/vba/function/LBound.htm
■4
また、For〜Nextステートメントで、配列(データの集まり)の0番目、1番目、2番目..と処理していくことは有用なアプローチですが、他にも配列から【一つずつ取り出して無くなるまで】処理する「For Each〜Nextステートメント」を使ってみるというのもアリだと思います。
■5
最後に、上記を踏まえて、提示のあったコードを私なりに整理してみると、こんな感じになりました。
よかったら参考にしてみてください。
Option Explicit Sub テキトー() Dim fpath As String Dim fname As String Dim sh1 As Worksheet Dim r1 As Long, r2 As Long Dim sr As Long, tr As Long Dim i As Integer Dim 列文字 As Variant '追加(For Each 〜 Next ステートメント用)
'▼ダイアログを出してフォルダを指定してもらう With Application.FileDialog(msoFileDialogFolderPicker) If .Show = False Then Exit Sub fpath = .SelectedItems(1) & "\" End With
Stop 'ブレークポイントの代わり
Set sh1 = ThisWorkbook.Worksheets("Sheet1") sr = 4
'▼指定してもらったフォルダの中のExcelファイルのみを処理の対象にする fname = Dir(fpath & "*.xls", vbNormal) Do Until fname = ""
'// Withステートメントに集約出来るので「wb」「sh2」は廃止 // With Workbooks.Open(fpath & fname).Worksheets("Sheet1") sh1.Range("B" & sr) = .Range("K2") tr = 0
'// 配列を扱うなら For Each 〜 Next ステートメントを使うという手もある '// (その場合「tbl」は同ステートメントに集約出来るから廃止) For Each 列文字 In Array("E", "F", "K", "L", "M", "N", "X", "Y", "Z", "AA", "AB") r2 = sr - 1
For r1 = 6 To .Cells(Rows.Count, 列文字).End(xlUp).Row If .Cells(r1, 列文字).Value <> "" Then r2 = r2 + 1 sh1.Cells(r2, i + 3).Value = .Cells(r1, 列文字).Value
'★ If r2 > tr Then tr = r2 End If
End If Next r1 i = i + 1 Next 列文字
sr = tr + 1
'▼ Workbooks.Open(fpath & fname).Worksheets("Sheet1")の親(=開いたブック)を閉じる .Parent.Close End With
fname = Dir() Loop End Sub
■6
余談ですが、「tr」って何に使ってるんでしょうか?
一応、★の部分で使ってますが、実質的にはなにも役立ってませんよね…
(もこな2) 2020/07/31(金) 19:23
それ以外は動作が正常にせず、検証するも難しかったため、今回は断念いたしました。
そもそも、どうやら元データの一部にミスがあったことも変な挙動の原因だったようでした。
そもそもこちらのミスで、大変申し訳有りません。
Uboundの実装と、数値の見直しなどで、最終的には正常に動作してくれました。
インデントやデバックなど、最低限必要な技術を教えていただき、ありがとうございました。
特にブレークポイント設定のステップ検証はどのコードがどのような働きをするかがわかり、非常にありがたかったです。
ご教授いただきありがとうございました。
(おでん) 2020/08/06(木) 18:08
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.