Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

3084 / 76807

←次へ　｜　前へ→


	【79362】Re:複数ブック・複数シートから1行コピーしてまとめたい

sakura - 17/9/5(火) 12:11 -


	引用なし

	パスワード

おそらく、かなりおなしなことをしてしまっているだろうと思い、自分なりに…の部分を割愛させていただきましたが…
恥をしのんで、、
下記のように、もとのコードの59行目の Set wh = Workbooks… の部分を、教えていただいたコードに置き換えました。
また、25行目+指定している TargetSheet もこのままではダメかな⁈と思い、コメントにしています。
お手数をおかけして申し訳ありませんが、もしよろしければ、どこをどう変更すれば良いか、までお教えいただけると大変助かります。
勉強不足で大変恐縮です。。
よろしくお願いいたしますm(__)m

Sub アンケート集計実行()
　　Dim wbn As Workbook
　　Dim wb As Workbook
　　Dim tb As Workbook
　　Dim TotalDir As String
　　Dim TotalSheet As String
　　Dim TargetSheet As String
　　Dim TargetFile As String
　　Dim TargetRow As String
　　Dim StartRow As String
　　Dim LastRow As String
　　Dim modeFlag As Boolean
　
'====================================================
'　　　　　　　　　　　値の設定
'====================================================
　
　　' 集計対象フォルダの指定
　　TotalDir = "C:\Users\NS26517\OneDrive - Teijin-Frontier\201708法務審査_下請調査関係\アンケート集計"

　　' 集計対象シートの指定
　　TargetSheet = "Sheet1"
　　　
　　' 集計用シートの指定
　　TotalSheet = "集計"
　　　
　　' 集計対象行の指定
　　TargetRow = "2"
　
　　' 集計結果記載開始行を指定
　　StartRow = "2"
　
　　' 追記するかしないかフラグ(True : 追記する、False: 追記しない)
　　modeFlag = False

'====================================================
'　　　　　　　　　　　実処理
'====================================================
　　Set tb = ThisWorkbook
　
　　If modeFlag = False Then
　　　　　　LastRow = tb.Sheets(TotalSheet).Rows(Rows.Count).End(xlUp).Row + 1
　　　　　　tb.Sheets(TotalSheet).Range(StartRow & ":" & LastRow).Delete
　　End If
　　　
　　TargetFile = Dir(TotalDir & "\*.xlsx", vbNormal)
　　Do While TargetFile <> ""
　　　　If TotalDir & "\" & TargetFile <> TotalFile Then
　　　　　　For Each wbn In Workbooks
　　　　　　　　If wbn.Name = TargetFile Then
　　　　　　　　　　MsgBox TargetFile & " は、既に開かれています。" & vbCrLf & "集計処理を中止します。"
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　Next wbn
　　　　　　Set wb = Workbooks.Open(TotalDir & "\" & TargetFile)
　　　　　　For Each ws In wb.Worksheets
　　　　　　　　If ws.Name Like "Sheet*" Then
　　　　　　LastRow = tb.Sheets(TotalSheet).Rows(Rows.Count).End(xlUp).Row + 1
　
　　　　　　' 行ごとのコピーを行うとなぜかずれるので値のみコピーしてみる。
　　　　　　wb.Sheets(TargetSheet).Rows(TargetRow).Copy
　　　　　　tb.Sheets(TotalSheet).Rows(LastRow).PasteSpecial (xlPasteValues)
　　　　　
　　　　　　' クリップボード警告対策
　　　　　　tb.Sheets(TotalSheet).Range("A1").Copy
　　　　　
　　　　　　' 集計対象ファイルを閉じる
　　　　　　wb.Close False

　　　　End If
　　　
　　　　TargetFile = Dir()
　　Loop
　
　　' クリップボード警告対策
　　tb.Sheets(TotalSheet).Range("A1").Copy
　
　　' 集計ファイルを保存
　　tb.Save

　　' 集計後のファイルを閉じる
　　' tb.Close True
　
　　' 完了を通知
　　MsgBox "集計を完了しました。"
End Sub

2 hits

▼

【79354】複数ブック・複数シートから1行コピーしてまとめたい sakura 17/9/3(日) 0:05