お世話になっております。

とりあえずはVBAが使えるレベルの初心者なのですが
社内で使っているVBAの集計マクロが重くて改修したいと思っております。

なんかざっと見た所
※Case文が多い
【勝手に思っている解決方法】→（出来るかどうか知らないが関数の配列っぽいので高速化出来ないか？）
※文字列をコピーするのに一々一つずつコピーしている
【勝手に思っている解決方法】→（空白のシートに【結局】一々コピーして最後にまとめて配列コピー）
などまだ構成段階ですが思っております。

上記※の2点に関してお伺いいたします。
※Case文を関数に　というのは出来るのでしょうか？
※配列に書いてまとめて配列をコピー　というのは配列を作成する段階でコピーしているので意味が無いような気がしますが
何か値をコピーするのに高速化する方法はあるのでしょうか？
今は

    For Col = 1 To 44
        With Ws.Cells(TargetRo, Col)
            Select Case Col
                Case 1
'                    strDatを作る処理
                    .Value = strDat
                Case 2
'                    strDatを作る処理
                    .Value = strDat
：
；
                Case 44 
                    .Value = Dat(Col - 4)
            End Select
        End With
    Next

上記のように実装しております。
ですが重いので配列にコピーして最後に配列でうんこらしょとコピーした方が早いらしいので
そのようにしようかと思っていましたが結局値を上記のように入れているのであんまり意味が無いのかと思っております。

Teratailを検索すると
VBA - Excel VBA 行挿入の高速化｜teratail
が見つかったので画面更新は止めようかと思っていますが
上記2点
・Case文を関数で配列化出来るか？
・配列コピーの方が早いが結局は作業用ワークシートにコピーするので意味が無いのでは無いか？

以上2点お問い合わせいたします。

またVBA　高速化　でググって出てきた文章を上から見ていくと
VBAの高速化 - 人はエクセルの能力の10%も使っていない？
がためになりそうでしたので後で実装予定です。

　【追記】

何かおもったようにパフォーマンスが上がらないので私は何か勘違いしているのかと思い
ソースの概要を貼り付けてアドバイスを頂ければと思ったため貼り付け失礼します。

vba
1Public Function Main(actWs As Worksheet) As Boolean 'Thisworkbook.getData
2
3'宣言とか色々
4
5    Debug.Print Time & " - スタート"
6
7    Const fDebug As Boolean = False 'Falseだと高速化対応中
8    If (fDebug) Then
9    Else
10        Dim wb As Workbook
11        Set wb = Workbooks.Open(strPath & strFileName)
12        '　　　　↑↑↑↑↑↑↑が時間がかかるとの事なのでこちらを一回にまとめました
13    End If
14
15    For i = 0 To UBound(SheetNamesList)
16        '読み込んでいるとのプログレスバーの処理
17        With ProgForm
18            If i > .ProgressBar1.Min And _
19                i <= .ProgressBar1.Max Then
20                'ProgressPercent = CInt(i / UBound(SheetNamesList) * 100)
21                .Label1.Caption = "評価表シートからデータを読み込んでいます。( " & i + 1 & " / " & UBound(SheetNamesList) + 1 & ")"
22                .ProgressBar1.Value = i 'プログレスバーの値を更新
23                DoEvents '滞留処理を実行
24            End If
25        End With
26        '読み込んでいるとのプログレスバーの処理ココまで
27        
28        If (fDebug) Then
29            '評価表シートからデータの取得
30            Dat = ReadData(strPath, strFileName, SheetNamesList(i), EvaluationListType)
31            '↑でなんか毎回閉じている気がするので開きっぱなしでやってみたのが↓ で早くなったかどうか分からないので……元のヤツを持ってくるか……
32        Else
33            'こっちは早くしたつもりなんだけどな……
34            Dat = ReadDataEx2(wb, SheetNamesList(i), EvaluationListType)
35        End If
36'不要かと思って削除したがココが重い予感　ココから================================
37        If IsArray(Dat) Then
38            Debug.Print Time, "PutData", "Start"
39            '集計表へのデータ記入 下が重い
40            If (fDebug) Then
41                If Not PutData(actWs, Dat, SheetNamesList(i)) Then GoTo ErrProc3
42            Else
43                If Not PutDataEx2(actWs, Dat, SheetNamesList(i)) Then GoTo ErrProc3
44            End If
45            
46            Debug.Print Time, "PutData", "End"
47        Else
48             Msg = "「" & SheetNamesList(i) & "」シートが削除されているか、評価表年度と台帳年度が一致しません。" & vbLf _
49             & "　このシートの読み込みをスキップします。"
50             Call Tools.ShowInfForm2("E", "シートの不在確認", True, "閉じる", False, "", Msg, 0, 0)
51        End If
52'不要かと思って削除したがココが重い予感　ココまで================================
53
54    Next
55
56    If (fDebug) Then
57    Else
58        wb.Close SaveChanges:=False
59    End If
60
61    Debug.Print Time & " - エンド"
62
63Exit Function
64
65
66'	ReadDataが重かったのでReadDataEx2に改修。
67'	改修した手法としては
68'	・Workbook.openが重いとの事で一つ開きっぱなしにして毎回Openしない
69'	・
70Private Function ReadDataEx2(ByVal wb As Workbook, ByVal SheetNames) As Variant
71'評価表からデータ取得
72
73
74    Dim Dat(40) As Variant, KeyWord As Variant
75    Dim BizWs As Worksheet, Msg As String
76    Dim PathFileSheet As String, strTemp As String
77    Dim i As Integer, FiscalYear As Integer
78    Dim Repres As String, JobPosition As String
79    
80    'CellDatas内にデータをコピー
81    Dim CellDatas As Variant
82    CellDatas = wb.Sheets(SheetNames).Range("A1:AI35")
83    
84    On Error GoTo ErrProc
85    FiscalYear = Val(CellDatas(2, 13))    '年度表示
86    '年度の整合性検査
87    'Debug.Print Val(ThisWorkbook.ActiveSheet.Cells(1, 1).Value)
88    If FiscalYear <> Val(ThisWorkbook.ActiveSheet.Cells(1, 1).Value) Then
89        GoTo ErrProc
90    End If
91    '読み取りシートがない場合はエラー
92'    Dat(1) = ExecuteExcel4Macro(PathFileSheet & 5 & "C" & 5) '評価実施日
93'    Dat(1) = CLng(wb.Sheets(SheetNames).Cells(5, 5).Value)     '評価実施日
94    Dat(1) = CLng(CellDatas(5, 5))     '評価実施日
95    If Dat(1) > ThisWorkbook.RecentRatingDay Then ThisWorkbook.RecentRatingDay = Dat(1)
96    On Error GoTo 0
97    
98    Dat(2) = CellDatas(6, 5)         '評価店所名
99    With EvaluationSheet '評価表
100        
101        Dat(4) = CellDatas(12, 11)         '業種CD
102        Dat(5) = CellDatas(12, 5)        '業務内容/品目
103        
104'このような内容がDat(34)まで続いている
105        'Dat(34) = ExecuteExcel4Macro(PathFileSheet & 11 & "C" & 11) '取引先担当者
106        'Dat(34) = wb.Sheets(SheetNames).Cells(11, 11).Value           '取引先担当者
107        Dat(34) = CellDatas(11, 11)           '取引先担当者
108        
109        '業務内容/品目
110        On Error GoTo ErrProc
111        KeyWord = Split(wb.Sheets(SheetNames).Cells(35, 3).Value, ",")
112        ReDim Preserve KeyWord(3)
113        For i = 0 To 3 'UBound(KeyWord)
114            Dat(35 + i) = Left(KeyWord(i), 12)  'Dat(35)～Dat(38)
115            If Dat(35 + i) = "" Then Dat(35 + i) = "-"
116        Next
117        On Error GoTo 0
118    
119    End With
120    
121     '文字種の変更
122    For i = 0 To UBound(Dat)
123        If Dat(i) <> "" And i <> 9 And i <> 34 Then Dat(i) = ChangeChr(Dat(i), i) 'i=7,8はCol=10,11
124    Next
125
126    ReadDataEx2 = Dat
127    
128Exit Function
129
130ErrProc:
131    ReadDataEx2 = "Err"
132
133End Function
134

土日にでもじっくり見て動作の高速化を考えてみますがどうすれば早くなりそうかコメント頂ければ幸いです。

【追記その2】

'なので高速化予定として作成するか……
Private Function PutDataEx2(Ws As Worksheet, Dat As Variant, EvaluationSheetName As Variant) As Boolean
    Dim LastRo As Long, TargetRo As Long
    Dim Col As Integer, strDat As String
    Dim temp As Variant, Msg As String, Res As Integer
    
    LastRo = getLastRoExTempRow(Ws) 'テンプレート行-1
    'cells(9,11)は「この行はテンプレートです。記入できません。」
    If LastRo < 9 Then TargetRo = 9 Else TargetRo = LastRo + 1
    Call CopyTemplateRow(Ws, TargetRo)
        
    '評価表の二重オープンを防ぐこと
    PutDataEx2 = True
    For Col = 1 To 44 '43 '42
        With Ws.Cells(TargetRo, Col)
           Select Case Col
                Case 1
                    If Dat(14) = "継続" Then
                        strDat = "2"
                    ElseIf Dat(14) = "新規" Then
                        strDat = "1"
                    Else
                        strDat = ""
                    End If
                    .Value = strDat
                Case 2
                    If Dat(15) = "外注" Then
                        strDat = "2"
                    ElseIf Dat(15) = "資材" Then
                        strDat = "1"
                    Else
                        strDat = ""
                    End If
                    .Value = strDat
’どうしても.VLookupなどをどのように実装すれば良いのか不明なので追記
	         Case 5 '評価店所名
	             If Dat(2) = "" Then
	                 Msg = "「評価店所名」に記入がありません。"
	                 GoTo ErrProc
	             End If
	             .Value = Dat(2)
	             '-----店番
	             temp = Replace(Dat(2), "支店", "")
	             temp = Replace(temp, "事業所", "")
	             temp = Replace(temp, "営業所", "")
	             With Worksheets("業種CD") '店番
	                 On Error Resume Next
	                 temp = Application.WorksheetFunction _
	                 .VLookup(temp, .Range(.Cells(3, 5), .Cells(31, 6)), 2, False)
	                 On Error GoTo 0
	             End With
	             .Offset(0, -2).Value = temp
’追記ココまで　ErrProcは省略します。.VLookupや.Offsetの実装方法を知りたいので

'　こういったのが　　↓まで続く
                Case 44 '前一年間の取引実績
                    .Value = Dat(Col - 4)
                Case Else
'                      If Ro = 9 And Col = 5 Then Ws.Cells(5, 8).Value = Dat(0) & "継続外注取引先"
                    .Value = Dat(Col - 3) 'Dat(Col - 5)
                    
            End Select
            '取引店所、業種名、取引先名カナ、取引先名、代表者職位・氏名、住所、条件、取引先担当者名、業務内容/品目1～4
'            If Col = 5 Or Col = 8 Or Col = 10 Or Col = 11 Or Col = 12 Or Col = 14 Or Col >= 37 Then
                .Font.Name = "Meiryo UI"
'            End If
        End With
    Next
End Function

hatena19

2021/03/01 10:40

たかだか44列の代入だけで時間がかかるとは思えません。 strDatを作る処理に時間がかかっている可能性の方が高いです。 strDatの部分を定数値に置き換えて実験してみてどのくらい時間がかかるか測定してみてください。

meg_

2021/03/01 12:05

> 画面更新は止めようかと思っていますが現在は何分かかっているのでしょうか？上記対応でどのくらい速くなりましたか？

jinoji

2021/03/01 13:09

strDatを作る処理は各列によって全て異なるのですか？

hatena19

2021/03/01 13:11

画面更新抑制、配列を使用してセルアクセスを極力減らすというのはそれなりに効果はありますが、提示のコードは44回のセルアクセス、代入ですので体感できる改善はないでしょう。 Case文も時間がかかるような処理ではありません。何に時間がかかっているかを特定することが先決でしょう。「strDatを作る処理」を省いて実行して時間を計測してみる。「strDatを作る処理」だけを取り出して時間を計測してみる。というような作業をまずはしましょう。

『🎄teratailクリスマスプレゼントキャンペーン2024🎄』開催中！

＼teratail特別グッズやAmazonギフトカード最大2,000円分が当たる！／

【追記】

【追記その2】

関連した質問

　【追記】