フォルダ内の全てのExcelを転記し、それぞれ名前をつけて保存するマクロをつくりました。これに、項目番号別に、それぞれ別のブックを作成する機能を追加したいです。

Question

既に作成済みのマクロに機能を追加したいです。

フォルダ内にあるExcelファイル（数千個）の必要項目(ファイルによってどの行までデータがあるか異なる)をExcelファイル(雛形)へ転記し、名前をつけてコピーを保存。その後Excelファイル（雛形）のデータをクリアし、フォルダ内の次のExcelファイルの必要項目を転記、、というループ処理をするマクロを組んでいます。

転記したExcelには、E列に関数を組んでおり、転記結果をもとに行を項目番号1,2,3....に分類できる仕様にしました。
項目番号が複数ある場合は、項目番号毎に、それぞれExcelファイル（雛形）に転記し名前をつけて保存するという条件分岐をつけたいです。

回答者様にご教示いただいた内容を反映させました。
何日も色々直し続けても分からず、困っていたため本当にありがとうございます。

追加で以下の点について改善したく、お力添えいただきたいです。

①項目別に作成する際に1つめのブックのみ、F10を転記し、2つ目以降については、F10の値をクリアしたいです。
もう一つ変数を組んでやろうとしましたが、上手くいきませんでした。

②不要な行を削除する文言になっているが、F〜H以外の行は、値を計算する関数が組まれているため、F〜Hの13行目以降の不要な値クリアし、F13:H13から下へ表示する仕様に変更したい
（削除すると#REFとなり計算ができなくなってしまいました。解決難しければ、再度以前作成した転記ツールで転記し直すため、こちらは必ずしも改善しなくても大丈夫です。）
'最終行が不定期な列を項目番号が一致しない場合は削除
For i = maxRow To 13 Step -1
If CStr(ws.Range("E" & CStr(i)).Value) <> CStr(k) Then ws.Rows(i).Delete

何卒、よろしくお願いいたしますm(__)m

 
Sub tenki() 
 
 Dim folder As String 
 Dim file As String 
 Dim book As Workbook 
 Dim i As Integer 
 
'指定のフォルダを開く
With Application.FileDialog(msoFileDialogFolderPicker) 
 If .Show = True Then 
   folder = .SelectedItems(1) 
 
 End If 
End With 
 
'指定フォルダ内のすべてのフォルダに実行
file = Dir(folder & "*.xls") 
 Do While file <> "" 
 
'フォルダ内のブックを開く
 Set book = Workbooks.Open(folder & "\" & file) 
 
'必要項目を雛形ファイルへ転記
ThisWorkbook.Worksheets("計算シート").Range("F7").Value = book.Worksheets("計算シート").Range("F7").Value 
 
ThisWorkbook.Worksheets("計算シート").Range("G7").Value = book.Worksheets("計算シート").Range("G7").Value 
 
ThisWorkbook.Worksheets("計算シート").Range("I7").Value = book.Worksheets("計算シート").Range("I7").Value 
 
ThisWorkbook.Worksheets("計算シート").Range("O7").Value = book.Worksheets("計算シート").Range("O7").Value 
 
ThisWorkbook.Worksheets("計算シート").Range("F10").Value = book.Worksheets("計算シート").Range("F10").Value 
 
 '必要項目のうち、最終行が不定期な列を最終行まで転記
Dim moto As Worksheet 
Dim saki As Worksheet 
Dim maxRow 
 
Set moto = book.Worksheets("計算シート") 
Set saki = ThisWorkbook.Worksheets("計算シート") 
maxRow = moto.Cells(Rows.Count, 1).End(xlUp).Row 
Dim dic, k 
Set dic = CreateObject("Scripting.Dictionary") 
 
 For i = 13 To maxRow 
 
saki.Range("F" & CStr(i)).Value = moto.Range("F" & CStr(i)).Value 
saki.Range("G" & CStr(i)).Value = moto.Range("G" & CStr(i)).Value 
saki.Range("H" & CStr(i)).Value = moto.Range("H" & CStr(i)).Value 
saki.Range("I" & CStr(i)).Value = moto.Range("I" & CStr(i)).Value 
 
k = saki.Range("E" & CStr(i)).Value 
dic(k) = "C:計算ツール格納フォルダ/計算ツール_" & Format(ThisWorkbook.Worksheets("変更前検証").Range("F7")) & "_" & Format(k) & ".xls" 
 
Next 
 
Dim fn As String 
Dim wb As Workbook 
Dim ws As Worksheet 
 
For Each k In dic 
fn = dic(k) 
ThisWorkbook.SaveCopyAs fn 
 
Set wb = Workbooks.Open(fn, ReadOnly:=False) 
Set ws = wb.Worksheets("計算シート") 
 
 '最終行が不定期な列を項目番号が一致しない場合は削除
For i = maxRow To 13 Step -1 
If CStr(ws.Range("E" & CStr(i)).Value) <> CStr(k) Then ws.Rows(i).Delete 
 
Next 

 '不要な列を削除した計算ツールを名前を付けて保存
wb.SaveAs fn
wb.Close

Next 
 

  Dim Filename As String 
  
  Filename = "C:計算ツール格納フォルダ/計算ツール_" & Format(ThisWorkbook.Worksheets("変更前検証").Range("F7")) & "_" & Format(k) & ".xls" 
  
  ThisWorkbook.SaveCopyAs Filename 
  Application.DisplayAlerts = False 
  
  file = Dir() 
  
 '転記対象のファイルを閉じる
  book.Close SaveChanges:=False 
  Application.DisplayAlerts = False 
  
'雛形ファイルに転記したデータを削除
 ThisWorkbook.Worksheets("計算シート").Range("F7").ClearContents 
 ThisWorkbook.Worksheets("計算シート").Range("G7").ClearContents 
 ThisWorkbook.Worksheets("計算シート").Range("I7").ClearContents 
 ThisWorkbook.Worksheets("計算シート").Range("O7").ClearContents 
 ThisWorkbook.Worksheets("計算シート").Range("F10").ClearContents 
 ThisWorkbook.Worksheets("計算シート").Range("F13:I200").ClearContents 
  
 
Loop 
 
 
End Sub 

Comments

[退会済みユーザー]

インデントがないコードは読みづらいです。
コードを貼る際はマークダウンを使用してください。

[mkmigmyuch]

失礼致しました。
インデントとはこのような直し方でよろしいでしょうか？
再度ご確認いただけるとありがたいです。

[退会済みユーザー]

質問を編集してください。
コードは入力欄上部の<code>クリックで挿入されるブロック内に貼ってください。

[mkmigmyuch]

失礼いたしました。
コードで挿入されるブロック内に入力いたしました。
操作方法について、ご教示いただきありがとうございます。
お手数おかけ致しました。

ご確認よろしくお願い致します。

Answer 1

自信ないけどこんな雰囲気でやったらどうでしょう。

   '必要項目のうち、最終行が不定期な列を最終行まで転記
    Dim moto As Worksheet, saki As Worksheet, maxRow
    Set moto = book.Worksheets("sheet1")
    Set saki = ThisWorkbook.Worksheets("sheet1")
    maxRow = moto.Cells(Rows.Count, 1).End(xlUp).Row
    Dim dic, k
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 13 To maxRow
        saki.Range("F" & CStr(i)).Value = moto.Range("F" & CStr(i)).Value
        saki.Range("G" & CStr(i)).Value = moto.Range("G" & CStr(i)).Value
        saki.Range("H" & CStr(i)).Value = moto.Range("H" & CStr(i)).Value
        saki.Range("I" & CStr(i)).Value = moto.Range("I" & CStr(i)).Value
        k = saki.Range("E" & CStr(i)).Value
        dic(k) = "C:計算ツール格納フォルダ/算ツール_" & Format(saki.Range("F7")) & Format(k) & ".xls"
    Next
    For Each k In dic
        ThisWorkbook.SaveCopyAs dic(k)
        With Workbooks.Open(dic(k))
            For i = maxRow To 13 Step -1
                If CStr(.Worksheets("sheet1").Range("E" & CStr(i)).Value) <> CStr(k) Then .Worksheets("sheet1").Rows(i).Delete
            Next
            .Save
            .Close False
        End With
    Next

Comments

[mkmigmyuch]

本日試したところ、ブック名を省略しているあたりがうまくいきませんでした。
色々いじってみましたがうまくいきませんでした。
省略している部分の認識があっているかわからないため、

If CStr(.Worksheets("sheet1").Range("E" & CStr(i)).Value) <> CStr(k) Then .Worksheets("sheet1").Rows(i).Delete
Next
.Save
.Close False

の部分を省略無しで記載いただけないでしょうか？

[jinoji]

書き換えるとこんな感じです。
Step実行するなどして、どこでどんな風にうまくいかないのか確認してみてください。
Dim fn As String, wb As Workbook, ws As Worksheet
For Each k In dic
fn = dic(k)
ThisWorkbook.SaveCopyAs fn
Set wb = Workbooks.Open(fn)
Set ws = wb.Worksheets(1)
For i = maxRow To 13 Step -1
If CStr(ws.Range("E" & CStr(i)).Value) <> CStr(k) Then ws.Rows(i).Delete
Next
wb.Save
wb.Close False
Next

[jinoji]

ファイルパスが変なのは環境に合わせて直してください

[mkmigmyuch]

ご回答いただきありがとうございます。
wbを指定してやってみたのですが、1周はできるのですが、2つ目のファイルの処理で
wb.Save
が上手くいかず止まってしまいます、、、
考えられる原因は何がありますでしょうか？
省略していたのでアクティブなブックを保存しようとしてエラーになると思っていましたが、wbを追加しても同じ場所がエラーで止まってしまいました。

[jinoji]

上手くいかず、とは具体的にはどんなエラーですか？

[mkmigmyuch]

抽象的な表現、失礼いたしました。
質問内容に、変更後のVBAと上手くいかない内容を記載しました。
お手数ですが、再度ご確認宜しくお願いします。
お付き合いいただき、大変感謝しております。
あと少しでできそうなのですが、色々いじってもなおせず、お力添えいただけると大変助かります。

[jinoji]

①④ Set wb = Workbooks.Open(fn, ReadOnly:=False, Ignorereadonlyrecommended:=True)
② wb.Save
‛ ThisWorkbook.SaveCopyAs Filename
として確認してみてください。

[mkmigmyuch]

ご確認いただきありがとうございました。
①④②の動作の不具合について、上記方法で改善いたしました。
また、F10のクリアもうまくいきました。

[mkmigmyuch]

列の削除については、分割したシートを再度雛形に転記すれば正しい関数で計算できるため、このままこのツールを使いたいと思います。
1週間以上悩んで書き換えてを繰り返していて、本当に困っていたので、大変助かりました。
前回も回答していただいて、今回も助けていただいて、本当にありがとうございました。大変感謝しています。
今回のエラーの原因にすぐ気づけなかったので、私ももっと勉強して、どこに不具合が生じているか、何が原因か、判別できるようになりたいと思いました。
ありがとうございました。