[[20200731133004]]　『VBAコードを書き換えたい』（おでん）　ページの最後に飛ぶ

『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

VBAに関してとても初心者のため、全くわからない状況です…
（コードも私が作ったものではなく、作ってもらったもので…）

まず質問側の知識がまったく伴っていないことを痛感しましたので、
勉強してみて、改めて質問をさせていただきます。

インデントしていただいたなか、大変申し訳有りません。

ただ、こちらのインデントをヒントに、まずコードを理解できるよう努めてみます。
ありがとうございます。
（おでん） 2020/07/31(金) 14:48

まず、tbl = Array("D", "W", "X", "Y", "Z") なので、tblは0～4番目までの5個の配列。
そして、For i = 0 To 4 というのは、これらを1つずつ取り出して使ってる。

さて、貴方は何処を変えたでしょう？他にも変えるところは無いですか？
足りないのは知識ではなく発想であり、気付くまで何度も試す根気です。
（???） 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項目になっているかと。０　～　１１
（隠居じーさん） 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

うん、0から始まっている、というのがミソですね。私が0番目から…、と解説していたのだし、自分で気付いて欲しかったところ。でも、列を増やしたなら i のループ数も増やす、という事に気づくには、知識なんて要らなかったでしょう？

ちなみに、知識があれば、より良い方法があります。ループの最大数を UBound(tbl) としてみてください。
（???） 2020/07/31(金) 15:55

ありがとうございます！
0番目からと言われたのに、理解できていませんでした、すみません…

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行ずつコードを実行して、変数がどのように変わっているのか確認したり、命令の結果どのような処理がされるのか観察するというアプローチが非常に有効だとおもいますので、方法を紹介します。

 ●「ステップ実行」とは
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

■２
さて、インデントについて既に言及されていますが、ご自身としては無い方が見やすいですか？
[[20180220104908]]　『ループの書き方』（ゆう）
↑の方のように強いこだわりがあり、どうしてもインデントを付けたくないのであれば仕方がありませんが、一般的にはインデントをつけて、コードを読みやすくするというアプローチはよく採られる手法ですので、こだわりがなければインデントをつけたほうがよいとおもいます。

■３
今回は配列について、0から始まっていて、UBoundで（添え字の）最大数を確認できると教わってます。
しかし、（今回は違いますが）１から始まるパターンもありますので、最"小"値を求める方法もセットとして覚えておくと良いと思います。

http://officetanaka.net/excel/vba/function/UBound.htm
http://officetanaka.net/excel/vba/function/LBound.htm

■４
また、For～Nextステートメントで、配列(データの集まり)の0番目、1番目、2番目..と処理していくことは有用なアプローチですが、他にも配列から【一つずつ取り出して無くなるまで】処理する「For Each～Nextステートメント」を使ってみるというのもアリだと思います。

■５
最後に、上記を踏まえて、提示のあったコードを私なりに整理してみると、こんな感じになりました。
よかったら参考にしてみてください。

    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

                sr = tr + 1

                '▼ Workbooks.Open(fpath & fname).Worksheets("Sheet1")の親（＝開いたブック）を閉じる
                .Parent.Close
            End With

            fname = Dir()
        Loop
    End Sub

■６
余談ですが、「tr」って何に使ってるんでしょうか？
一応、★の部分で使ってますが、実質的にはなにも役立ってませんよね…

（もこな２） 2020/07/31(金) 19:23

検証と確認に時間を要し、返信が遅くなりまして申し訳有りません。
Ubound、ありがとうございました。

それ以外は動作が正常にせず、検証するも難しかったため、今回は断念いたしました。

そもそも、どうやら元データの一部にミスがあったことも変な挙動の原因だったようでした。
そもそもこちらのミスで、大変申し訳有りません。
Uboundの実装と、数値の見直しなどで、最終的には正常に動作してくれました。

インデントやデバックなど、最低限必要な技術を教えていただき、ありがとうございました。
特にブレークポイント設定のステップ検証はどのコードがどのような働きをするかがわかり、非常にありがたかったです。

ご教授いただきありがとうございました。

（おでん） 2020/08/06(木) 18:08

コメント返信：

[ 一覧(最新更新順) ]

[[20200731133004]] 『VBAコードを書き換えたい』（おでん） ページの最後に飛ぶ

[[20200731133004]]　『VBAコードを書き換えたい』（おでん）　ページの最後に飛ぶ