[[20230310011733]]　『集計マクロがうまくいきません』（ねね）　ページの最後に飛ぶ

『集計マクロがうまくいきません』（ねね）

作りたいコードに関してうまくできず、アドバイス頂ければ幸いです。

Sub 集計マクロ()
Dim searchFolder As String

 Dim searchPattern As String

 Dim wb As Workbook

 Dim ws As Worksheet

 Dim pasteRange As Range

 Dim dataRange As Range

 Dim sheetNumber As Integer

 Dim linkRange As Range

 Dim cell As Range

 Dim destSheet As Worksheet ' 新しい変数の宣言

 Dim i As Integer ' シート数を数えるための変数の宣言

 ' 検索フォルダと検索パターンを設定

 searchFolder = ThisWorkbook.Path & "\"

 searchPattern = "*" & Range("設定!A1") & "*"

 ' フォルダ内の全てのファイルを検索

 Dim file As Variant

 file = Dir(searchFolder & searchPattern)

 sheetNumber = 1

 Application.DisplayAlerts = False

 ' 新しいシート名のための変数を初期化

 i = 1

 Do While file <> ""

 ' ファイルを開く

 Set wb = Workbooks.Open(fileName:=searchFolder & file, ReadOnly:=True, UpdateLinks:=False)

 For Each ws In wb.Worksheets

 If ws.Index >= 7 Then ' 7番目以降のタブのみ処理

 ' データを貼り付けるシートを取得

 On Error Resume Next

 Set destSheet = ThisWorkbook.Sheets("データ" & i)

 On Error GoTo 0

 If destSheet Is Nothing Then

 MsgBox "シートが存在しません。"

 Exit Sub

 End If

 ' ペースト先範囲を指定

 Set pasteRange = destSheet.Range("C" & sheetNumber + 35)

 ' リンクを貼る範囲を指定

 Set linkRange = ws.Range("G64:AM64")

 ' リンクを貼る

 For Each cell In linkRange.Cells

 pasteRange.Offset(cell.Row - linkRange.Row, cell.Column - linkRange.Column).Formula = "='" & wb.Path & "\[" & wb.Name & "]" & ws.Name & "'!" & cell.Address

 Next cell

 i = i + 1 ' シート数をカウントアップ

 End If

 Next ws

 wb.Close SaveChanges:=False

 file = Dir()

 sheetNumber = sheetNumber + 1 ' ペースト先のシートの行数を変更

 Loop

 Application.DisplayAlerts = True

 MsgBox "データの取り込みが完了しました。"

End Sub

マクロ組むエクセルと同フォルダに7つ(現時点)の課名エクセルあります。あいまい検索で1つづつ開きデータ集計。１つ集計完了後、次ファイルを開き集計を繰り返します
※検索で開くエクセルFMは全て同じだがデータ値が違う。複数タブあり一番左のタブから右に７つ目以降のタブを集計対象。タブ例）「ﾃﾞｰﾀ」「合計」「→」「職場1」「職場2」「職場3」...「職場7」「←」「その他」

集計は「職場1」～「職場7」
※ファイルにより増減
※本当は「→　←」内だけリンクしたいがそのように参照できない？
　そのため「右に７つ目以降のタブ」という指定で「職場1」～「その他」まで
　全部取ってしまおうと思います。

マクロ実行ファイル(※元ファイルとよぶ)に対象のタブC36:AI36以降の全セルリンク
タブは複数、その中で「データ1」～「データ7」あり

最初の集計対象ファイルは元ファイル「データ1」に入る
1.元ファイル「データ1」のC36:AI36に職場1のG84:AM84をリンク
2.元ファイル「データ1」のC37:AI37に職場2のG84:AM84をリンク
3.元ファイル「データ1」のC38:AI38に職場3のG84:AM84をリンク
上記の規則性

問題?@
現コードは「2.」以降「データ2」のC37:AI37に職場2のG84:AM84がリンクになるってしまいます。

問題?A
上記「?@」がうまくいかないにしろ、次のファイルまで開きあいまい検索で引っかかるエクセルを順番に開き処理がますが、最初以外のデータはどこにもリンクされていません。
上書きされてしまうのならわかるのですが・・・。

アドバイス頂ければ幸いです。
宜しくお願い致します。

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

 (1)
 変数sheetNumber変数　の機能と
 変数i                の機能が不整合になっていると思います。
 意味をよく考えてみて下さい。

 (2)なお、
 ＞※本当は「→　←」内だけリンクしたいがそのように参照できない？   
 のところは、例えば、
         index1 = wb.Worksheets("→").Index
         index2 = wb.Worksheets("←").Index
         For k = index1 + 1 To index2 - 1
             Set ws = wb.Worksheets(k)
             以下略
 こんな感じでよいのでは？

 (3)
 そもそもですが、インデントが正確についていないので、全体の構造がわかりにくいと思います。
 例えば、こんな風にすると、もっと見やすくなると思いますよ。（内容は一切変えていません）

 Sub 集計マクロ()
     Dim searchFolder As String
     Dim searchPattern As String
     Dim wb          As Workbook
     Dim ws          As Worksheet
     Dim pasteRange  As Range
     Dim dataRange   As Range
     Dim sheetNumber As Integer
     Dim linkRange   As Range
     Dim cell        As Range
     Dim destSheet   As Worksheet    ' 新しい変数の宣言
     Dim i           As Integer      ' シート数を数えるための変数の宣言
     Dim file        As Variant

     ' 検索フォルダと検索パターンを設定
     searchFolder = ThisWorkbook.Path & "\"
     searchPattern = "*" & Range("設定!A1") & "*"

     ' フォルダ内の全てのファイルを検索
     file = Dir(searchFolder & searchPattern)
     sheetNumber = 1
     Application.DisplayAlerts = False

     i = 1
     Do While file <> ""
         Set wb = Workbooks.Open(Filename:=searchFolder & file, ReadOnly:=True, UpdateLinks:=False)
         For Each ws In wb.Worksheets
             If ws.Index >= 7 Then
                 On Error Resume Next
                 Set destSheet = ThisWorkbook.Sheets("データ" & i)
                 On Error GoTo 0
                 If destSheet Is Nothing Then
                     MsgBox "シートが存在しません。"
                     Exit Sub
                 End If

                 Set pasteRange = destSheet.Range("C" & sheetNumber + 35)
                 Set linkRange = ws.Range("G64:AM64")
                 For Each cell In linkRange.Cells
                     pasteRange.Offset(cell.Row - linkRange.Row, cell.Column - linkRange.Column).Formula _
                           = "='" & wb.Path & "\[" & wb.Name & "]" & ws.Name & "'!" & cell.Address
                 Next cell
                 i = i + 1    ' シート数をカウントアップ
             End If
         Next ws
         wb.Close SaveChanges:=False
         file = Dir()
         sheetNumber = sheetNumber + 1    ' ペースト先のシートの行数を変更
     Loop
     Application.DisplayAlerts = True
     MsgBox "データの取り込みが完了しました。"
 End Sub

 # マル付き数字は文字化けするので、ここでは使わないで下さい。
（abc） 2023/03/10(金) 06:03:04

ご丁寧なご返信、アドバイスありがとうございます。

頂いた内容を確認し、コード修正にトライしてみたいと思います。

掲示板の使い方までわかっていなくて申し訳ございません。
しっかり覚えておきます。

まずはやってみます。
ありがとうございます
（ねね） 2023/03/10(金) 09:36:45

コメント返信：

[ 一覧(最新更新順) ]

[[20230310011733]] 『集計マクロがうまくいきません』（ねね） ページの最後に飛ぶ

[[20230310011733]]　『集計マクロがうまくいきません』（ねね）　ページの最後に飛ぶ