[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『追加したシートを書き込み対象にするには？』（粒）
指定したフォルダにある全てのエクセルファイルの全てのシートから、元ブックにある同じ名前のシートに情報を転記、同じ名前のシートが無ければその名前のシートを追加してそこに転記する、というマクロを書いていたのですが
追加したシートを書き込み対象として指定するための構文がわかりません。
どのような形で指定したらいいでしょうか。
以下がそのマクロです。
※このマクロは会社のパソコンで作成していて自宅にはエクセルの環境が無く、スマホで写真を撮ったものを書き写しているのでエラーとは関係のないところでスペルミス等をしているかもしれませんがご容赦ください。
Option Explicit
Sub 全完取得()
Dim fName As String '指定フォルダ名
Dim f As Object '指定フォルダ以内にあるファイル一覧
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim wb As Workbook
Dim Ows As Worksheet, Tws As Worksheet Dim flg As Boolean
Dim 配列() As Valiant Dim 最終 As Long Dim c As Long
Dim 全数 As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = False
.Title = "フォルダの選択"
If .Show = True Then
fName = .SelectedItems(1)
Else: Exit Sub
End If
End With
'全てのエクセルファイルに処理実行 ▼ここから
For Each f In fso.GetFolder(fName).Files
If fso.GetExtensionName(f.Path) = "xlsx" Then
Set wb = Workbooks.Open(Filename:=f, ReadOnly:=True)
For Each Ows In wb.Worksheets
'シート内番号範囲取得 ▼▼ここから
With Ows
If .Name = "H" Then
最終 = .Cells(.Rows.Count, 1).End(xlUp).Row
配列 = .Range(.Cells(4, 1), .Cells(最終 + 1, 1))
Else
最終 = .Cells(.Rows.Count, 1).End(xlUp).Row
配列 = .Range(.Cells(4, 1), .Cells(最終 + 1, 1))
End If
End With
'シート内番号範囲取得 ▲▲ここまで
c = WorksheetFunction.CountA(配列) '番号の数カウント
For Each Tws In ThisWorkbook.Worksheets
flg = False 'フラグリセット
'対応するシートにデータ追加 ▼▼ここから
'シートが存在した場合 ▼▼▼ここから
With Tws
If .Name = Ows.Name Then
全数 = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.Cells(全数 + 1, 1), .Cells(全数 + c, 1)).Value = 配列
flg = True 'シート追加フラグキャンセル
Exit For 'Twsの処理抜けてこのOwsについては終わり
End If
End With
'シートが存在した場合 ▲▲▲ここまで
Next Tws
'シートが存在しなかった場合 ▼▼▼ここから
If flg = False Then
ThisWorkbook.Worksheets.Add.Name = Ows.Name
ThisWorkbook.Worksheets(Ows.Name).Range(Cells(1, 1), Cells(c, 1)).Value = 配列 '★
End If
'シートが存在しなかった場合 ▲▲▲ここまで
'対応するシートにデータ追加 ▲▲ここまで
Next Ows '次のシートに処理継続
wb.Close
End If
Next f '全てのエクセルファイルに処理実行 ▲ここまで
End Sub
★のところでエラー1004「アプリケーション定義またはオブジェクト定義のエラーです」が出ます。
＜ 使用 Excel：Excel2013、使用 OS：Windows10 ＞
シートの存在判定のほうも、全部巡回するという方法もまちがいではありませんが、もうちょい手抜きするプランもありますよ。
Sub さんぷる()
Dim fName As String '指定フォルダ名
Dim f As Object '指定フォルダ以内にあるファイル一覧
Dim fso As Object
Dim wb As Workbook
Dim Ows As Worksheet, Tws As Worksheet
'▼下準備
Set fso = CreateObject("Scripting.FileSystemObject")
'ダイアログで対象フォルダを選択してもらう
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = False
.Title = "フォルダの選択"
If .Show = True Then
fName = .SelectedItems(1)
Else
MsgBox "フォルダが選択されなかったので処理を中止します"
Exit Sub
End If
End With
'全てのエクセルファイルに処理実行 ▼ここから
For Each f In fso.GetFolder(fName).Files
If fso.GetExtensionName(f.Path) = "xlsx" Then
Set wb = Workbooks.Open(Filename:=f, ReadOnly:=True)
For Each Tws In ThisWorkbook.Worksheets
With Tws
'▼wbに存在するTwsと同じ名前のシートをセットしようとしてみる
On Error Resume Next
Set Ows = Nothing
Set Ows = wb.Worksheets(.Name)
On Error GoTo 0
'▼処理分岐
If Ows Is Nothing Then
'//「Nothing」のままだったら失敗してるから、シートは存在してない
wb.Worksheets.Add after:=wb.Worksheets(wb.Worksheets.Count) '末尾にシートを追加
wb.Worksheets(wb.Worksheets.Count).Name = .Name '追加したシートの名前をTwsと同じ名前に変更
.Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Copy 'Twsの必要範囲をコピー
wb.Worksheets(wb.Worksheets.Count).Range("A1").PasteSpecial Paste:=xlPasteValues '追加したシートのA1セルを起点としたセル範囲に値貼り付け
Else
'//「Nothing」じゃなければ、シートが存在してるからそのシートに対して処理を実行
.Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Copy 'Twsの必要範囲をコピー
Ows.Cells(Ows.Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues 'OwsのA列最終行の１行下のセルを起点としたセル範囲に値貼り付け
End If
End With
Next Tws
wb.Close
End If
Next f
End Sub
（もこな２） 2021/02/18(木) 01:03
上の行と合わせて
With ThisWorkbook.Worksheets.Add
.Name = Ows.Name
.Range(.Cells(1, 1), .Cells(c, 1)).Value = 配列
End with
とすることでこのエラーは回避できます。
他の内容は見てないのでスミマセン
（一寸覗の半可通） 2021/02/18(木) 02:08
＞一寸覗の半可通 さん
確かにそこの指定を忘れていますね…
自分で言うのもなんですがこれは結構な凡ミスですね…
今後はRangeやCellsを使うときはどのブック、どのシートの話をしているのかもっと意識していこうと思います。
ということで以下のような形になり無事解決しました。
お二人とも回答ありがとうございました。
Option Explicit
Sub 全完取得()
Dim fName As String '指定フォルダ名 Dim f As Object '指定フォルダ内にあるファイル一覧
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim wb As Workbook Dim Ows As Worksheet, Tws As Worksheet
Dim 配列() As Variant Dim 最終 As Long Dim c As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = False
.Title = "フォルダの選択"
If .Show = True Then
fName = .SelectedItems(1)
Else
'MsgBox "キャンセルしました"
Exit Sub
End If
End With
Application.ScreenUpdating = False
'全てのエクセルファイルに処理実行 ▼ここから
For Each f In fso.GetFolder(fName).Files
If fso.GetExtensionName(f.Path) = "xlsx" Then
Set wb = Workbooks.Open(Filename:=f, ReadOnly:=True)
For Each Ows In wb.Worksheets
'Owsと同じ名前のシートをThisWorkbookからTwsとして呼び出す(有無にかかわらず)
On Error Resume Next
Set Tws = Nothing
Set Tws = ThisWorkbook.Worksheets(Ows.Name)
On Error Goto 0
With Ows 'Owsのシート名に応じた転記範囲取得 ▼▼ここから
If .Name = "H" Then
最終 = .Cells(.Rows.Count, 1).End(xlUp).Row
配列 = .Range("A4", .Cells(最終 + 1, 1))
Else
最終 = .Cells(.Rows.Count, 2).End(xlUp).Row
配列 = .Range("B4", .Cells(最終 + 1, 2))
End If
End With 'Owsのシート名に応じた転記範囲取得 ▲▲ここまで
c = WorksheetFunction.CountA(配列) '番号の数カウント
'同じ名前のシートに貼り付け ▼▼ここから
If Tws Is Nothing Then
'２回目のSetが失敗しているとOws.NameのTwsは存在していない(Nothing)
With ThisWorkbook.Worksheet.Add
.Name = Ows.Name
.Range("A1").Resize(c).Value = 配列
End With
Else
'失敗していなければTwsに処理実行 Twsは２回目のSetでOws.Nameに指定済み
Tws.Cells(Tws.Rows.Count, 1).End(xlUp).Offset(1).Resize(c).Value = 配列
End If
'同じ名前のシートに貼り付け ▲▲ここまで
Next Ows '貼り付け終わったらOws次のシートへ
wb.Close '全てのOwsで処理が終わったらこのfのwbは閉じる
End If 'fがエクセルファイルか判定するIf
Next f
'全てのエクセルファイルに処理実行 ▲ここまで
Application.ScreenUpdating = True
End Sub
（粒） 2021/02/18(木) 18:36
＞何故か2つ目のブックから処理がものすごく遅くなり
ちょっと↑が気になりますので、本当にコピーして値貼り付けすることに問題があるのか、ステップ実行して問題の切り分けをされたほうが良いかもしれません。
Sub さんぷる2()
Dim fso As Object
Dim fName As String, f As Object
Dim wb As Workbook
Dim srcSH As Worksheet, dstSH As Worksheet
Dim srcRNG As Range, dstRNG As Range
'▼下準備
Set fso = CreateObject("Scripting.FileSystemObject")
'▼ダイアログで対象フォルダを選択してもらう
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = False
.Title = "フォルダの選択"
If .Show = True Then
fName = .SelectedItems(1)
Else
MsgBox "フォルダが選択されなかったので処理を中止します"
Exit Sub
End If
End With
'▼ループ処理(フォルダの内の全ファイルを巡回する)
For Each f In fso.GetFolder(fName).Files
'▼拡張子を確認して”xlsx”だったら処理する（ブックを開いて「wb」にセットする）
If fso.GetExtensionName(f.Path) = "xlsx" Then
Set wb = Workbooks.Open(Filename:=f.Path, ReadOnly:=True)
'▼ループ処理（開いたブックの全シートを巡回する）
For Each srcSH In wb.Worksheets
'シートの存在判定
Set dstSH = Nothing
On Error Resume Next
Set dstSH = ThisWorkbook.Worksheets(srcSH.Name)
On Error GoTo 0
'シートの存在で処理分岐(出力先が変わる)
If dstSH Is Nothing Then
Set dstSH = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
Set dstRNG = dstSH.Range("A1")
Else
Set dstRNG = dstSH.Cells(dstSH.Rows.Count, "A").End(xlUp).Offset(1)
End If
'シートの名前で処理分岐（コピー元が変わる）
With srcSH
If srcSH.Name = "H" Then
Set srcRNG = .Range("A4", .Cells(.Rows.Count, "A").End(xlUp))
Else
Set srcRNG = .Range("B4", .Cells(.Rows.Count, "B").End(xlUp))
End If
End With
'Valueプロパティを参照して値を複写
dstRNG.Resize(srcRNG.Rows.Count, srcRNG.Columns.Count).Value = srcRNG.Value
Next srcSH
'全シートを巡回したら開いたブックを閉じる
wb.Close
End If
Next f
End Sub
（もこな２ ） 2021/02/24(水) 04:56
＞本当にコピーして値貼り付けすることに問題があるのか
確かにそうですね、ということで18日18:36に書き込んだマクロの転記に関する部分だけを
配列代入からコピー値貼り付けに書き換えてみたんですが、やはり2ブック目の処理で砂時計になりエクセルが落ちてしまいました。
コピー部分：
With Ows
If .Name = "H" Then
.Range("A4", Cells(.Rows.Count, 1).End(xlUp)).Copy
Else
.Range("B4", Cells(.Rows.Count, 2).End(xlUp)).Copy
End If
End With
貼り付け部分：
With ThisWorkbook.Worksheet.Add
.Name = Ows.Name
.Range("A1").PasteSpecial Paste:=xlPasteValues
End With
Tws.Cells(Tws.Rows.Count, 1).End(xlUp).PasteSpecial Paste:=xlPasteValues
でもブレークポイントをブックを閉じる直前と、次のブックを開いて転記を始める直前に設定した
それぞれのパターンでブックごとの処理のループを手動でまわして実行すると特に問題なく動くんですよね…
コピー範囲を残したまま次のブックに行くのがまずいのかと思ってブックを閉じる前に
Application.CutCopyMode = False
を挟んでみても特に変わらず…
現状の自分の知識では考えつく対応はここらが限界でした。
新しく提示していただいた、配列を挟まずにValue同士で直接代入の方式は普通に動いたので
「複数のブックでの連続の処理は値貼り付けは向いていないかもしれない？」くらいしかわかりませんでした…
（粒） 2021/02/24(水) 22:03
本当に自分で考えない人ばっかりですね。 手作業でコピペするのと同じ事をすれば良いのでは。 初心者だからと言い訳が来そうなので、 私はマクロ記録覚え初めで思いつきました。 （他力本願） 2021/02/24(水) 23:28
お前何しに来てんの？ 最近明らかな捨てネームでどうでもいい小言を単発で書き込むカスが湧いてるけどさあ 質問も回答もアドバイスもしないお前みたいなのはここじゃ誰にも必要とされてないし何の役にも立たないんだよね 自分で考えない？ 「単独だと動くけど連続させるとフリーズする」って話をしてんのに何をどうやったらマクロの記録で解決できるんだ？ 文字読めてるか？何も考えてないのはどっちだよ
（粒） 2021/02/26(金) 19:59
こんばんは！
>でもブレークポイントをブックを閉じる直前と、次のブックを開いて転記を始める直前に設定した >それぞれのパターンでブックごとの処理のループを手動でまわして実行すると特に問題なく動くんですよね…
それはあるかもしれませんね？ 手動とコードでは処理スピードが違いすぎますからね。
ハード的な制約もあるでしょうし、、定番ですけど、DoEventsで制御をOSに渡すとか DoEventsも一つで駄目なら二つ三つ重ねてみるとかでしょうか？？？
今回とは別ですけど、大きな配列を連続する場合は、途中で保存すると良かった様に思います （SoulMan） 2021/02/26(金) 21:32
もし、コピー先のブックに数式が入れてあったりする場合は、 自動再計算を止めてみるっていうのはどうでしょう DoEvents も効くとおもいますが。
Sub sample()
Dim FSO As Object, File As Object
Dim WB As Workbook, WSfrom As Worksheet, WSCopyTo As Worksheet
Dim targetColumn As Integer, LastRow As Long, CopyRow
Const HeaderRows = 3
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = False
.Title = "フォルダの選択"
If .Show Then fName = .SelectedItems(1) Else Exit Sub
End With
Set FSO = CreateObject("Scripting.FileSystemObject")
With Application.Calculation = xlCalculationManual ' 自動再計算を止めてみる
For Each File In FSO.GetFolder(fName).Files
If LCase(FSO.GetExtensionName(File.Path)) = "xlsx" Then
Set WB = Workbooks.Open(Filename:=File.Path, ReadOnly:=True)
For Each WSfrom In WB.Worksheets
Set WSCopyTo = SetWorksheetsByName(ThisWorkbook, WSfrom.Name)
Select Case WSfrom.Name
Case "H": targetColumn = 1
Case Else: targetColumn = 2
End Select
With WSfrom
LastRow = .Cells(.Rows.Count, targetColumn).End(xlUp).Row
End With
With WSCopyTo
CopyRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If WSCopyTo.Cells(CopyRow, 1) <> "" Then CopyRow = CopyRow + 1
End With
WSCopyTo.Cells(CopyRow, 1).Resize(LastRow - HeaderRows).Value = WSfrom.Cells(4, targetColumn).Resize(LastRow - HeaderRows).Value
DoEvents: DoEvents
Next
WB.Close False
End If
Next
With Application.Calculation = xlCalculationAutomatic
End Sub
Function SetWorksheetsByName(WB As Workbook, shName As String) As Worksheet
On Error GoTo Err_NoSheets
Set SetWorksheetsByName = WB.Worksheets(shName)
On Error GoTo 0
Exit Function
Err_NoSheets:
With WB
Set SetWorksheetsByName = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
SetWorksheetsByName.Name = shName
End With
End Function
（´・ω・`） 2021/02/27(土) 02:43
それが特定できれば、集約する側のシートがたくさんになりすぎているとか、データ元側のシートに問題があるとか、解決のヒントになったりしないですかね・・
（もこな２ ） 2021/03/11(木) 15:07
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.