Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(指定なし : Excel 2016)
コードの助言をお願いします
投稿日時: 20/12/27 16:27:44
投稿者: m024240

よろしくおねがいします。
 
陸上大会の集計表をマクロを使って自動化できないかと思いました。
 
事前に記録を記入するシートを配布し、記入後に送り返してもらう予定です。
大会は30〜50(従って返送されるブックも30〜50)ぐらいあり、
各大会の参加者人数もばらばらです。(各大会200名程度までと予想しています)
 
構想としては、返送されたブックを1つのフォルダに入れて、
1ブックずつ開いて カテゴリ1シートのB24:K最終行 をコピーし、
集計ブック、カテゴリ1シートの B6以降(5行目がタイトル行になっている)に貼り付けていくというイメージです。
そこで以下のようなコードを作りました。
---------------------------------------------------------------------
Private Sub CommandButton1_Click()
Dim bkSrc As Workbook 'コピー元ワークブック
Dim folderPath As String '処理対象のフォルダパス
Dim itm As Object
Dim LastRow1 As Long 'コピー元の最終行取得
Dim LastRow2 As Long '集計先の最終行取得
 
'Excel該当ファイルが保存されているフォルダを選択
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False '複数選択しない
    .Title = "Excelファイルが保存されているフォルダを選択"
    If .Show = True Then
        folderPath = .SelectedItems(1) '選択したフォルダのパスを変数に格納
    Else
        Exit Sub 'フォルダが選択されなかった場合は処理終了
    End If
End With
 
'ファイルの処理にFileSystemObjectオブジェクトを利用
With CreateObject("Scripting.FileSystemObject")
    '指定したフォルダ内のファイルを順番に処理
    For Each itm In .GetFolder(folderPath).Files
        '処理対象となるファイルの拡張子を指定
        Select Case LCase(.GetExtensionName(itm))
        Case "xls", "xlsx", "xlsm"
            Set bkSrc = Application.Workbooks.Open(itm.Path) '元のワークブックを開く
            LastRow1 = bkSrc.Worksheets("カテゴリ1").Range("B" & Rows.Count).End(xlUp).Row
            LastRow2 = ThisWorkbook.Worksheets("カテゴリ1").Range("B" & Rows.Count).End(xlUp).Row
            bkSrc.Worksheets("カテゴリ1").Range("B24:K" & LastRow1).Copy
            ThisWorkbook.Worksheets("カテゴリ1").Range("B" & LastRow2 + 1).PasteSpecial xlPasteValues
            bkSrc.Close SaveChanges:=False 'コピー元のワークブックを変更せずに閉じる
        End Select
    Next
End With
End Sub
-----------------------------------------------------------
ここで質問ですが、
1)動きがとてもユックリなので、もう少しきびきびさせる方法はないか?
2)「クリップボードに大きなデータが残っていますが残しますか、クリアしますか」のダイアログが出るので、表示せずに進めさせる方法はありますか?
 
コードは、ネットで見つけたものを組み合わせているのでおかしなところが多いと思いますが、
よろしくお願いします。、
 
 
 

回答
投稿日時: 20/12/27 17:31:31
投稿者: WinArrow
投稿者のウェブサイトに移動

感想
 
対象ブックを開くまでのコードが長い
 Getopenfilenameを使えば、数行で済みます。
これでどれだけ早くなるかはわかりませんが・・・
でもフォルダ検索が必要ならば、それほど変わらないか・・・
 
クリップボードの話は、
方法は2つ
 
方法1
貼付け後、
Application.CutCopymode = False
を実行すればよいでしょう。
 
方法2
そもそも、クリップボードを使わない方法
コードのイメージ
受け側セル範囲.Value = 送り側セル範囲.Value
 

回答
投稿日時: 20/12/27 17:35:23
投稿者: WinArrow
投稿者のウェブサイトに移動

Thisworkbookには、セルに数式が入っていますか?
若し、数式が入っていたら、再計算モードを手動に変更してください。

回答
投稿日時: 20/12/27 17:39:17
投稿者: hatena
投稿者のウェブサイトに移動

m024240 さんの引用:

1)動きがとてもユックリなので、もう少しきびきびさせる方法はないか?
2)「クリップボードに大きなデータが残っていますが残しますか、クリアしますか」のダイアログが出るので、表示せずに進めさせる方法はありますか?

 
   bkSrc.Worksheets("カテゴリ1").Range("B24:K" & LastRow1).Copy
   ThisWorkbook.Worksheets("カテゴリ1").Range("B" & LastRow2 + 1).PasteSpecial xlPasteValues

 
上記の部分を下記に書き換えれば、すこし高速化して、ダイアログは出ないようにできます。
 
        With bkSrc.Worksheets("カテゴリ1").Range("B24:K" & LastRow1)
            ThisWorkbook.Worksheets("カテゴリ1").Range("B" & LastRow2 + 1). _
                    Resize(.Rows.Count, Columns.Count).Value = .Value
        End With

 
あと、処理の最初に、
 
Application.ScreenUpdating = False
 
処理に最後に
 
Application.ScreenUpdating = True
 
を記述して、画面更新を停止すればすこし高速化する可能性があります。
 
開くファイルが多くて、上記だけでは思ったほど高速化しない、ということなら、ファイルを開かずに取得する方法を検討することになります。
 
ADOを使ってエクセルファイルに接続して、SQLでレコードセットとしてデータを取得して、取り込み先シートに出力するということになります。
 
ADO(ActiveX Data Objects)の使い方の要点|VBA技術解説
https://excel-ubara.com/excelvba4/EXCEL273.html
 
 
 

投稿日時: 21/01/12 14:38:27
投稿者: m024240

返信が遅くなりました。
PCの不調でコードを修正するのが遅くなりました。
おまけに、まとめレスとなることをお許しください。
 
結論として、自分で満足のできるものになりました。
助言いただいた方、ありがとうございました。
 
 
WinArrow 様
 
>>Application.CutCopymode = False
 
>>Thisworkbookには、セルに数式が入っていますか?
>>若し、数式が入っていたら、再計算モードを手動に変更してください。
 
2点の助言ありがとうございました。
 
 
 
hatena 様
 
>>あと、処理の最初に、
>>Application.ScreenUpdating = False
>>処理に最後に
>>Application.ScreenUpdating = True
 
コードに入れました。
 
これをもって、解決済みとさせていただきます。