Excel VBAで作れますか？

ＶＢＡ勉強して半年の初心者です。
以下の記述ですが、データが多い時はかなりの時間がかかります。
プログレスバーやステータスバーを表示するにはどうすればよいのでしょうか？
宜しくお願いします。

※フォルダ内のデータをブックのシートに一旦コピーしてコピーしたシートを
１シートにまとめるＶＢＡです。

Option Explicit

Sub 集約VBA() 'Name

'【変数宣言】
Dim datafile As Variant
Dim 集約book As Workbook
Dim 集約sheet As Workbook
Dim myfolder As Variant
Dim mysheet As Worksheet
Dim data転記 As Integer
Dim 不要sheet As Worksheet
Dim メッセージ As String
Dim bc As Integer
Dim 戻値 As String
Dim 有効 As Boolean

'【エラーファイルチェック】
If Dir(ThisWorkbook.Path & "\" & "Alldata.xlsx") <> "" Then

MsgBox "ファイル名 :【 Alldata.xlsx 】が既に存在しています。" & Chr(13) & Chr(13) & _
"フォルダ内から [移動] または [削除] して下さい。"

Exit Sub '"Alldata.xlsx"ファイルが存在していれば処理を終了。

End If

Application.ScreenUpdating = False '画面更新を一時停止。

'【処理値の選択】
メッセージ = _
"処理番号を入力してください。" & Chr(13) & Chr(13) & _
" 1 :フォルダ内にあるBook dataを集約します。" & Chr(13) & Chr(13) & _
"※ 空欄または [キャンセル] ボタンで中止します。"

Do
戻値 = InputBox(Prompt:=メッセージ, Default:="") 'InputBoxの初期値＝空白。

If 戻値 = "" Then Exit Sub

If 戻値 = "1" Then 有効 = True

Loop While 有効 = False

'【対象データの抽出】
Set 集約book = ThisWorkbook

myfolder = ThisWorkbook.Path

datafile = Dir(myfolder & "\*.xls*")

If datafile = "" Then Exit Sub

Do Until datafile = Empty

If datafile <> 集約book.Name Then

If LCase(Right(datafile, 4)) = ".xls" Or LCase(Right(datafile, 5)) = ".xlsx" Then

Set 集約sheet = Workbooks.Open(myfolder & "\" & datafile)

集約sheet.Worksheets.Copy After:=集約book.Sheets(集約book.Sheets.Count)

集約sheet.Close

bc = bc + 1

End If

End If

datafile = Dir()

Loop

'【不要シート削除】
On Error Resume Next

Application.DisplayAlerts = False

For Each mysheet In Worksheets

If mysheet.Range("A2").Text = "" Then mysheet.Delete

Next mysheet

Application.displayalrts = True

Set mysheet = Nothing

On Error GoTo 0

'【抽出したデータの転記】
Worksheets(1).Copy Before:=Sheets(1)

ActiveSheet.Name = "Alldata"

For data転記 = 3 To Worksheets.Count

With Worksheets(data転記)

.Range(.Rows(2), .Rows(2).End(xlDown)).Copy

End With

Rows(Range(Rows(1), Rows(1).End(xlDown)).Rows.Count + 1).Insert Shift:=xlDown

Next data転記

Application.CutCopyMode = False

'【転記用シート以外削除】
For Each 不要sheet In Sheets

If Not (不要sheet.Name = "Alldata") Then

Application.DisplayAlerts = False

不要sheet.Delete

Application.DisplayAlerts = True

End If

Next 不要sheet

'【集約したデータを新規ブックに名前を付けて保存】
ActiveSheet.Copy

ActiveWorkbook.SaveAs Filename:=myfolder & "\" & "Alldata"

集約book.Close savechanges:=False

Application.ScreenUpdating = True

Range("A1").Select

MsgBox "正常に処理が完了しました。"

End Sub

No.3 ベストアンサー 回答者： よろずやkinchan 回答日時： 2019/03/20 17:36

プログレスバーを表示する目的は、後どの位待てばよいかの目安を与えるものです。

ということは、残りの処理がどれだけあるかを把握している必要があります。

Do Loop では、全体のファイル数を取得しているわけではないので、
処理に先立ってファイル数を取得する必要があります。

ただ単に進行状況を表示するだけでよければ、

Do Until datafile = Empty
Application.StatusBar = datafile '←追加
:
:
MsgBox "正常に処理が完了しました。"
Application.StatusBar = False '←追加
End Sub

ってな感じで。

この回答へのお礼

よろずやkinchan様
ありがとうございます。
このＶＢＡではステータスバーに進捗状況を％表示は
厳しいのですね。
ご無理なご相談をしてしまい申し訳ありませんでした。
いろいろと教えて頂き有難うございました。

お礼日時：2019/03/23 10:50

No.4 回答者： tatsu99 回答日時： 2019/03/20 22:53

＞プログレスバーやステータスバーを表示するにはどうすればよいのでしょうか？

https://www.sejuku.net/blog/72730

こちらが参考になりませんでしょうか。上記のサイトで表示する方法は習得できますが、
そもそも、今現在、何パーセントまで終わっているのかは、自分で計算する必要があります。
その為には、No3の方がいわれているように、処理対象となるファイルの総数を予め知っておく必要があります。
現在の％の値＝処理済みファイル数／ファイル総数×１００
で表示することは可能です。但し、1つのファイルの処理にかかる時間が、ほぼ同じであるという前提になります。
特定のファイルだけ、処理時間が、非常に長くかかるような場合は、正しい表示にはなりません。

この回答へのお礼

tatsu99様
以前も、大変お世話になり感謝しております。
参考ＵＲＬを確認して再度挑戦してみたいと思います。
ありがとうございました。

お礼日時：2019/03/23 10:51

No.2 回答者： よろずやkinchan 回答日時： 2019/03/20 14:26

追加するのではなく、全体をコピペして実行してみてください。

この回答へのお礼

よろずやkinchan様
実行できました。
直接保存ファイルにデータをコピーできました。
ありがとうございます。

このＶＢＡにプログレスバーやステータスバーの追加は
不可能でしょうか？
内容によってできないものもあるみたいなので・・・

お礼日時：2019/03/20 14:37

No.1 回答者： よろずやkinchan 回答日時： 2019/03/19 21:34

Option Explicit

Sub 集約VBA() 'Name
'【変数宣言】
Dim datafile As Variant
Dim 集約book As Workbook
Dim 集約sheet As Workbook
Dim myfolder As Variant
Dim mysheet As Worksheet
'Dim data転記 As Integer
'Dim 不要sheet As Worksheet
Dim メッセージ As String
'Dim bc As Integer
Dim 戻値 As String
Dim 有効 As Boolean
'【エラーファイルチェック】
If Dir(ThisWorkbook.Path & "\" & "Alldata.xlsx") <> "" Then
MsgBox "ファイル名 :【 Alldata.xlsx 】が既に存在しています。" & Chr(13) & Chr(13) _
& "フォルダ内から [移動] または [削除] して下さい。"
Exit Sub '"Alldata.xlsx"ファイルが存在していれば処理を終了。
End If
Application.ScreenUpdating = False '画面更新を一時停止。
'【処理値の選択】
メッセージ = "処理番号を入力してください。" & Chr(13) & Chr(13) _
& " 1 :フォルダ内にあるBook dataを集約します。" & Chr(13) & Chr(13) _
& "※ 空欄または [キャンセル] ボタンで中止します。"
Do
戻値 = InputBox(Prompt:=メッセージ, Default:="") 'InputBoxの初期値＝空白。
If 戻値 = "" Then Exit Sub
If 戻値 = "1" Then 有効 = True
Loop While 有効 = False
'【対象データの抽出】
' Set 集約book = ThisWorkbook
myfolder = ThisWorkbook.Path
datafile = Dir(myfolder & "\*.xls*")
If datafile = "" Then Exit Sub
ThisWorkbook.Sheets(1).Copy '←追加
Set 集約book = ActiveWorkbook '←追加
Do Until datafile = Empty
' If datafile <> 集約book.Name Then
If datafile <> ThisWorkbook.Name Then '←追加
If LCase(Right(datafile, 4)) = ".xls" Or LCase(Right(datafile, 5)) = ".xlsx" Then
Set 集約sheet = Workbooks.Open(myfolder & "\" & datafile)
' 集約sheet.Worksheets.Copy After:=集約book.Sheets(集約book.Sheets.Count)
For Each mysheet In 集約sheet.Worksheets '←追加
With mysheet '←追加
If .Range("A2").Text <> "" Then '←追加
.Range(.Rows(2), .Rows(.Rows.Count).End(xlUp)).Copy '←追加
With 集約book.Sheets(1) '←追加
.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial xlPasteAll '←追加
End With '←追加
Application.CutCopyMode = False '←追加
End If '←追加
End With '←追加
Next mysheet '←追加
集約sheet.Close
' bc = bc + 1
End If
End If
datafile = Dir()
Loop
'【不要シート削除】
' On Error Resume Next
' Application.DisplayAlerts = False
' For Each mysheet In Worksheets
' If mysheet.Range("A2").Text = "" Then mysheet.Delete
' Next mysheet
' Application.displayalrts = True
' Set mysheet = Nothing
' On Error GoTo 0
'【抽出したデータの転記】
' Worksheets(1).Copy Before:=Sheets(1)
' ActiveSheet.Name = "Alldata"
' For data転記 = 3 To Worksheets.Count
' With Worksheets(data転記)
' .Range(.Rows(2), .Rows(2).End(xlDown)).Copy
' End With
' Rows(Range(Rows(1), Rows(1).End(xlDown)).Rows.Count + 1).Insert Shift:=xlDown
' Next data転記
' Application.CutCopyMode = False
'【転記用シート以外削除】
' For Each 不要sheet In Sheets
' If Not (不要sheet.Name = "Alldata") Then
' Application.DisplayAlerts = False
' 不要sheet.Delete
' Application.DisplayAlerts = True
' End If
' Next 不要sheet
'【集約したデータを新規ブックに名前を付けて保存】
' ActiveSheet.Copy
' ActiveWorkbook.SaveAs Filename:=myfolder & "\" & "Alldata"
' 集約book.Close savechanges:=False
集約book.Sheets(1).Name = "Alldata" '←追加
集約book.SaveAs Filename:=myfolder & "\" & "Alldata.xlsx" '←追加
集約book.Close '←追加
Application.ScreenUpdating = True
Range("A1").Select
MsgBox "正常に処理が完了しました。"
End Sub

この回答へのお礼

よろずやkinchan様
このたびは誠にありがとうございます。
追加して実行を行いましたが、一番下のLoopに対するDoがないと出ます。
私の見落としがあるのでしょうか？宜しければ確認できますでしょうか？

For Each mysheet In 集約sheet.Worksheets
With mysheet
If .Range("A2").Text <> "" Then
.Range(.Rows(2), .Rows(.Rows.Count).End(xlUp)).Copy
With 集約book.Sheets(1)
.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial xlPasteAll
End With
Application.CutCopyMode = False
End If
End With
Next mysheet
集約sheet.Close
bc = bc + 1
End If
End If
datafile = Dir()
Loop ←このループに対するDoがありませんと出ます。

お礼日時：2019/03/20 11:26