[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『追加したシートを書き込み対象にするには?』(粒)
指定したフォルダにある全てのエクセルファイルの全てのシートから、元ブックにある同じ名前のシートに情報を転記、同じ名前のシートが無ければその名前のシートを追加してそこに転記する、というマクロを書いていたのですが
追加したシートを書き込み対象として指定するための構文がわかりません。
どのような形で指定したらいいでしょうか。
以下がそのマクロです。
※このマクロは会社のパソコンで作成していて自宅にはエクセルの環境が無く、スマホで写真を撮ったものを書き写しているのでエラーとは関係のないところでスペルミス等をしているかもしれませんがご容赦ください。
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列最終行の1行下のセルを起点としたセル範囲に値貼り付け End If End With Next Tws
wb.Close End If Next f End Sub
(もこな2) 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 '2回目のSetが失敗しているとOws.NameのTwsは存在していない(Nothing) With ThisWorkbook.Worksheet.Add .Name = Ows.Name .Range("A1").Resize(c).Value = 配列 End With Else '失敗していなければTwsに処理実行 Twsは2回目の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
(もこな2 ) 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
それが特定できれば、集約する側のシートがたくさんになりすぎているとか、データ元側のシートに問題があるとか、解決のヒントになったりしないですかね・・
(もこな2 ) 2021/03/11(木) 15:07
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.