リストオブジェクトへの追加、削除する方法

テーブルの作り方

上の画像のようにリストを作成し、ショートカットキー「Ctrl ＋ T」を押しテーブル化する。
画像の蛍光線部「デザイン　→　テーブル名を｛柱DB｝とする」。

これでテーブルが完成。

Enumを使ってイミディエイトウィンドウに表示する。

Option Explicit

Enum 柱
    氏名 = 1
    所属
    性別
End Enum

Sub test1()

Dim DB1 As ListObject   '柱テーブル用
Dim i As Long

Set DB1 = Sheet1.ListObjects("柱DB")

'イミディエイトウィンドウに表示
For i = 2 To DB1.ListRows.Count + 1
    Debug.Print DB1.Range(i, 柱.氏名), DB1.Range(i, 柱.所属), DB1.Range(i, 柱.性別)
Next

End Sub

以下の画像の通り、リストデータが表示される。

本題のリストへの追加、削除の方法

結論

'テーブルの最終行に追加
DB1.ListRows.Add.Range.Value = Array("かずやん", "エクセル", "男")

'テーブルの最終行を削除
DB1.ListRows.Item(DB1.ListRows.Count).Delete

Add、Deleteで追加、削除をする。

一瞬だけ柱になってみる。

Option Explicit

Enum 柱
    氏名 = 1
    所属
    性別
End Enum

Sub test1()

Dim DB1 As ListObject   '柱テーブル用
Dim i As Long

Set DB1 = Sheet1.ListObjects("柱DB")


'テーブルの最終行に追加
DB1.ListRows.Add.Range.Value = Array("かずやん", "エクセル", "男")


'テーブルの最終行を削除
DB1.ListRows.Item(DB1.ListRows.Count).Delete


'イミディエイトウィンドウに表示
For i = 2 To DB1.ListRows.Count + 1
    Debug.Print DB1.Range(i, 柱.氏名), DB1.Range(i, 柱.所属), DB1.Range(i, 柱.性別)
Next

End Sub

上記のコードを動かすと、Addしたとき一瞬だけ柱になれますｗ。即削除しますがｗ。

リストオブジェクトの追加、削除の方法備忘録でした。

ではでは、この辺で(^^)/~~~

第２回：「請求書入力フォームで入力したデータをPDF出力し、請求書DBに転記する」

第２回のコード

Option Explicit

Sub MakeInvoicePdf()

'変数定義------------------------------------------------------------
Dim company As String, staff As String, subject As String
Dim demandNo As Integer, demandDate As Date
Dim sumOfMoney As Currency, dueDate As Date
Dim productNameInDetail As Variant

Dim ws As Worksheet, fileName As String, bookNameDB As String
'変数定義終了________________________________________________________


Set ws = Worksheets("請求書")


'変数取得処理--------------------------------------------------------
company = ws.Range("A4").MergeArea.Item(1)       '会社名
staff = ws.Range("B6").MergeArea.Item(1)         '担当者
subject = ws.Range("B9").MergeArea.Item(1)       '件名
demandNo = ws.Range("G4").Value                  '請求No
demandDate = ws.Range("G5").Value                '請求日
sumOfMoney = ws.Range("B17").MergeArea.Item(1)   '合計金額
dueDate = ws.Range("G17").Value                  '支払期限
productNameInDetail = ws.Range("A20：G30").Value '品名詳細
'____________________________________________________________________


'PDF印刷処理---------------------------------------------------------

fileName = ThisWorkbook.Path & "\印刷PDF\請求番号_" & demandNo

ws.ExportAsFixedFormat Type:=xlTypePDF, fileName:=fileName
'____________________________________________________________________


'DB書込み処理--------------------------------------------------------
bookNameDB = ThisWorkbook.Path & "\請求データDB.xlsx"

Workbooks.Open bookNameDB

Dim wbDB As Workbook: Set wbDB = ActiveWorkbook
Dim wsWriteDB As Worksheet: Set wsWriteDB = ActiveWorkbook.Sheets("請求書DB")
Dim i As Byte
Dim write_IX As Long

'最終行の取得処理
write_IX = wsWriteDB.Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To 11
    If productNameInDetail(i, 2) <> "" Then
         '書込み処理
         write_IX = write_IX + 1
         
         wsWriteDB.Cells(write_IX, 1) = company     '会社
         wsWriteDB.Cells(write_IX, 2) = staff       '担当者
         wsWriteDB.Cells(write_IX, 3) = subject     '件名
         wsWriteDB.Cells(write_IX, 4) = demandNo    '請求No
         wsWriteDB.Cells(write_IX, 5) = demandDate  '請求日
         wsWriteDB.Cells(write_IX, 6) = dueDate     '支払期限
         wsWriteDB.Cells(write_IX, 7) = productNameInDetail(i, 1)   '品名No
         wsWriteDB.Cells(write_IX, 8) = productNameInDetail(i, 2)   '品名
         wsWriteDB.Cells(write_IX, 9) = productNameInDetail(i, 5)   '数量
         wsWriteDB.Cells(write_IX, 10) = productNameInDetail(i, 6)  '単価
         wsWriteDB.Cells(write_IX, 11) = productNameInDetail(i, 7)  '金額
         wsWriteDB.Cells(write_IX, 12) = sumOfMoney  '合計金額
         
    End If
Next


'請求データDBを保存して閉じる
wbDB.Save
wbDB.Close
'____________________________________________________________________


MsgBox "請求No_" & demandNo & "、PDF作成完了。" & Chr(10) & "DB登録完了"

End Sub

処理イメージ

処理イメージの動画です。 https://t.co/Y66uSnsPHB pic.twitter.com/3akINn68Ol

— かずやん_VBAerLv.５ (@y8bV4ty1wbkTjPd) 2021年1月6日

ツッコミ・質問

１　ＤＢ登録後に、Sheetに済みの印をつける。（DBの重複登録を防ぐ）。

２　シートの位置指定がデザインに引っ張られてコードが安定していない。

３　テーブル機能を利用した代替案もみてみたい。（代表的な保守性を欠くコードになっているため）

４　インデントが一般的にみるスタイルよりも１つ少ないのはどうしてですか？

５　変数へのコメントは、変数宣言時の方がよい

６　変数は日本語で書いた方がいいのでは？？

７　変数名の設定が気になる（load/save、from/to、src/dest、・・・対義語の選択についてもう少し注意すると語感がよくなる）。

８　CSVなどのデータを一括処理できないか？？（自分で思った）

第１回：FSOで写真の更新日時を調べる。スマホの写真をまとめたい。Twitterレビュー後の追記。

FileSysytemObjectを使って、写真の作成、更新、アクセス日時を調べる

過去記事で、PowerShellを使って写真の作成日時を元にフォルダを作成し格納するというShellを作ったことがありました。

bimori466-1.hatenablog.com

ExcelにはＦＳＯがあり、「作成、更新、アクセス日時」を調べることができるので同じようなものができることに気づき、作ってみました。

PowerShellは書き方が違うので、慣れないためExcelで作った方が馴染みやすいと思い作ってみました。

写真が増えたのは、子どもの写真を撮りすぎて整理の収集がつかなくなったからです。
アルバム作る時に「年、月」で整理していれば、成長の過程がわかりやすいかなという感じです。

子どもの将来のためにも整理してあげよう、という多少の親心をみせます。

目次
　 １　閲覧対象者
　 ２　得られる効果
　 ３　設計
　 ４　ＶＢＡの処理を解説　
　 ５　作ってみての感想　
　 ６　Twitterでレビューしてもらったら…
　 ７　使ってみたい方（noteのリンク）

１　閲覧対象者

大量の写真を作成日時で「年、月」ごとのフォルダにざっくり仕分けしたい人

２　得られる効果

大量の写真ファイルが、

「年、月」ごとに仕分けされて、格納される。

処理イメージ

処理イメージの動画Gifです。

これを作ったきっかけは、スマホで撮った子どもの写真を整理するためです！

これで処理イメージを持っていただけたらと！ pic.twitter.com/yxbI87MmUH

— かずやん_VBAerLv.５ (@y8bV4ty1wbkTjPd) 2020年12月30日

３　設計

２のフォルダに写真を格納する。
１のエクセルマクロ実行。
３のフォルダに「年、月」ごとに写真が格納される。

＊２，３のフォルダが１のエクセルのPATHになければ、２，３フォルダを作成する（Workbook_Open）。

４　ＶＢＡの処理を解説

ＦＳＯで、作成、更新、アクセス日時」を調べる。

まずは、写真の「作成、更新、アクセス日時」をMsgboxに表示してみます。

結果

処理コード

Sub 写真の最終日時を取得()

Dim fso As Object
Set fso = CreateObject("scripting.filesystemobject")
Set f = fso.GetFile("ファイルPATH\＊.jpg")

MsgBox "  作  成  日  時   ：" & FileDateTime("ファイルPATH\＊.jpg") & vbCrLf & _
       "最終更新日時　：" & f.DateLastModified & vbCrLf & _
       "最終アクセス日時：" & f.DateLastAccessed

picture_date = FileDateTime("ファイルPATH\＊.jpg"")
picture_year = Year(picture_date)
picture_month = Month(picture_date)
picture_day = Day(picture_date)
picture_hour = Hour(picture_date)
picture_minute = Minute(picture_date)
picture_second = Second(picture_date)


Set f = Nothing


End Sub

解説

作　成　日　時　　→　FileDateTime("ファイルPATH\＊.jpg") 　＊ＦＳＯは関係ない。
最終更新日時　　　→　f.DateLastModified
最終アクセス日時　→　f.DateLastAccessed

読んでそのままで、わかりやすいです。
Msgboxの下のコードは、作成日時から「年、月、日、時、分、秒」が取得できることを表しています。
つまり、ここの「年、月」で条件分岐すればフォルダーを作成し写真を格納する処理が作れるということです。

本題の写真を「年、月」ごとに格納するマクロ

ＦＳＯで作成日時の「年、月」から、フォルダがあるか調べる。
フォルダがあれば、写真をそのフォルダに移動する。
フォルダがなければ、フォルダを作って写真をそのフォルダに移動する。

これだけです。

noteにはフォルダがアップできなかったので、このExcelを開いたら、同じPathにフォルダを作成するようにしました。（ThisWorkBookに処理記述）。

ＶＢＡのコード

標準モジュール　年月別にフォルダを作成

Sub 年月別にフォルダを作成()

'処理時間の計測-----------------------------------------------------------------------------------
Dim startTime As Double
Dim endTime As Double
Dim processTime As Double

startTime = Timer
'__________________________________________________________________________________________________


Dim targetFolder As String
Dim loadFolder As String

targetFolder = ThisWorkbook.Path & "\" & "写真を仕分けて格納"
loadFolder = ThisWorkbook.Path & "\" & "処理対象写真を格納する"


Dim fso_lord, fso_traget As Object
Set fso_lord = CreateObject("scripting.filesystemobject")
Set fso_traget = CreateObject("scripting.filesystemobject")

Set f = fso_lord.GetFolder(loadFolder)
Set f2 = fso_traget.GetFolder(targetFolder)
Set fc = f.Files


'ファイル数が０なら処理終了。
If fc.Count = 0 Then MsgBox "対象ファイルなし": Exit Sub


'主処理
For Each f1 In fc

    '.jpgを処理。
    If f1.Name Like "*.jpg" Or f1.Name Like "*.JPG" Then
        '年、月を取得する。
        picture_date = FileDateTime(f1)
        picture_year = Year(picture_date)
        picture_month = Month(picture_date)
        FolderName = picture_year & "年" & picture_month & "月"
        SearchFolder = targetFolder & "\" & FolderName
        
        'フォルダが存在するか調べる
        If fso_traget.FolderExists(SearchFolder) Then
            '存在する場合は格納処理
            fso_lord.MoveFile f1, SearchFolder & "\"
            
        Else
            '存在しない場合は、フォルダを作って格納処理

            'フォルダ作成
            fso_traget.createfolder SearchFolder
            
            'ファイルを格納
            fso_lord.MoveFile f1, SearchFolder & "\"
            
        End If
        
    End If
Next f1


'処理時間の計測-----------------------------------------------------------------------------------
endTime = Timer
processTime = endTime - startTime

MsgBox "end 処理時間＝" & Round(processTime / 60, 0) & "分" & Round(processTime Mod 60, 0) & "秒"
'__________________________________________________________________________________________________


End Sub

ThisWorkBook　フォルダを作成するコード

Private Sub Workbook_Open()

Dim fso As Object
Set fso = CreateObject("scripting.filesystemobject")

SearchFolserPath = ThisWorkbook.Path
Search1 = "処理対象写真を格納する"
Search2 = "写真を仕分けて格納"

'ファルダが存在するか調べる

If fso.FolderExists(SearchFolserPath & "\" & Search1) Then
    'フォルダ有、処理なし。
Else
    'フォルダなし、フォルダを作る
    fso.createfolder SearchFolserPath & "\" & Search1
    MsgBox "フォルダ：「処理対象写真を格納する」を作成しました。"
End If


If fso.FolderExists(SearchFolserPath & "\" & Search2) Then
    'フォルダ有、処理なし。
Else
    'フォルダなし、フォルダを作る
    fso.createfolder SearchFolserPath & "\" & Search2
    MsgBox "フォルダ：「写真を仕分けて格納」を作成しました。"
End If

    
End Sub

５　作ってみての感想

意外と簡単にできました。Pwershellはあんまり使わないので、VBAで作った方が親しみがわきます。
約２００枚の写真を１３秒くらいで仕分けできました。割と早いので、処理速度は問題なしかと。

６　Twitterでレビューしてもらったら…

この記事の内容を「#VBAの悩みはVBAerに聞け」にUPしたところ以下の指摘点がありました。
１　fsoは概念上１つでよいはず
２　制御コードの重複
３　拡張子判断の正規化(JPG)
４　fsoを使わなかったらどういうコードになるか（番外編）

それぞれ、解説していきます。

１　fsoは概念上１つでよいはず

ツッコミのあったのは以下のコードです。

Dim fso_lord As Object, fso_traget As Object
Set fso_lord = CreateObject("scripting.filesystemobject")
Set fso_traget = CreateObject("scripting.filesystemobject")

変数をfso_lord、fso_traget２つ宣言しています。そしてこの２つをFSOとしてSETしています。
この部分が１つでいんじゃね？？というご質問でした。

該当する処理部分は以下のコード

'フォルダが存在するか調べる
If fso_traget.FolderExists(SearchFolder) Then
    '存在する場合は格納処理
     fso_lord.moveFile f1.Path, SearchFolder & "\"
            
Else
   '存在しない場合は、フォルダを作って格納処理

    'フォルダ作成
     fso_traget.createfolder SearchFolder
            
     'ファイルを格納
     fso_lord.moveFile f1.Path, SearchFolder & "\"
            
End If

フォルダが存在するか調べる場合はfso_tragetを使い、ファイルを格納（moveFile）するときは、fso_lordを使っていました。
しかし、FSOの構造を考えると変数は１つでいいのです。実際に以下のように、変数fso_tragetを、fso_lordに変更しても処理は変わりません。

変数fso_traget → fso_lordに変更したコード。

'フォルダが存在するか調べる
If fso_lord.FolderExists(SearchFolder) Then
        
　　'存在する場合は格納処理
　　fso_lord.moveFile f1.Path, SearchFolder & "\"
            
 Else
　　'存在しない場合は、フォルダを作って格納処理

　　'フォルダ作成
　　fso_lord.createfolder SearchFolder
            
　　'ファイルを格納
　　fso_lord.moveFile f1.Path, SearchFolder & "\"
            
 End If

これでも同じように動きます。それはなぜか？？
結論は、FileSystemObjectはファイルシステムを抽象化したもので、フォルダを抽象化したものではない。ファイルシステムは１つです。
この回答が一番しっくりきました。
つまり、１つしかないファイルシステムに対して複数変数宣言する意味あんの？？ということです。回答としては、「無い」です。
実際、変数fso_lordだけでもちゃんと処理ができていますｗ

２　制御コードの重複

ツッコミがあったのは以下のコードです。

'フォルダが存在するか調べる
If fso_lord.FolderExists(SearchFolder) Then

    '存在する場合は格納処理
    fso_lord.moveFile f1.Path, SearchFolder & "\"
    
Else
    '存在しない場合は、フォルダを作って格納処理

    'フォルダ作成
    fso_lord.createfolder SearchFolder
    
    'ファイルを格納
    fso_lord.moveFile f1.Path, SearchFolder & "\"
    
End If

つまりは、「fso_lord.moveFile f1.Path, SearchFolder & "\"」が重複してるよ！ということを質問されていました。
最初は、サブルーチン化すればいいのかなと思ったのですが、答えはもっと簡単なことでした。
ポイントは、「fso_lord.moveFile f1.Path, SearchFolder & "\"」この処理はＩＦ文の中に書く必要ないんじゃない！？フォルダだけ作って、ファイルの格納処理はＩＦ文外でやればいいじゃんということでした。

修正後のコード

'フォルダが存在するか調べる
If fso_traget.FolderExists(SearchFolder) = False Then
    '存在しない場合は、フォルダ作成
    fso_traget.createfolder SearchFolder
End If

'ファイルを格納
fso_lord.moveFile f1, SearchFolder & "\"

非常にコードがすっきりしました。
重複して記述していた「fso_lord.moveFile f1, SearchFolder & "\"」の処理も１行のみになりました。

３　拡張子判断の正規化(JPG)

ツッコミがあったのは以下のコードです。

If f1.Name Like "*.jpg" Or f1.Name Like "*.JPG" Then

小文字のjpgと大文字のJPGに対応させるために「Or」を使っています。しかし、これはLCase、UCaseを使えば「Or」を使う必要はないとのことでした。

改善後のコード（大文字にして判定）

If UCase(myFile.Name) Like "*.JPG" Then

これで「Or」を使う必要はなくなりました。

４　fsoを使わなかったらどういうコードになるか（番外編）

これは時間のある時に考えます(;^ω^)

以上の質問を受けた上での最終コード

Option Explicit

Dim fso As Object

Sub PhotoOrganize()

'変数定義------------------------------------------------------------
Dim targetFolder As String: targetFolder = ThisWorkbook.Path & "\" & "写真を仕分けて格納"
Dim loadFolder As String: loadFolder = ThisWorkbook.Path & "\" & "処理対象写真を格納する"
Dim targetCount As Long
Dim picture_date As String, picture_year As String, picture_month As String
Dim FolderName As String, SerachFolder As String

'定義終了____________________________________________________________

Set fso = CreateObject("scripting.filesystemobject")

'ファイル数が０なら処理終了。
If fso.GetFolder(loadFolder).Files.Count = 0 Then MsgBox "対象ファイルなし": Exit Sub

'主処理
Dim myFile As Object
For Each myFile In fso.GetFolder(loadFolder).Files
    '.jpgを処理。
    If UCase(myFile.Name) Like "*.JPG" Then
        '年、月を取得する。
        picture_date = FileDateTime(myFile)
        picture_year = Year(picture_date): picture_month = Month(picture_date)
        FolderName = picture_year & "年" & picture_month & "月"
        SearchFolder = targetFolder & "\" & FolderName
        
        Call Fnc_MoveFile(myFile.Path, SearchFolder & "\")
        
    End If
Next
    
End Sub

Fnc_MoveFile部のコード

Function Fnc_MoveFile(moveFolder As String, beforFolder As String)

'フォルダが存在するか調べる
If fso.FolderExists(beforFolder) = False Then
    'フォルダ作成
    fso.createfolder beforFolder
    
End If

'ファイル格納処理
fso.moveFile moveFolder, beforFolder

End Function

非常にすっきりしたコードになりました。ご質問いただいた方々ありがとうございました。m(_ _"m)

７　使ってみたい方（noteのリンク）

noteから無料でダウンロードできます。
興味のある方は、お試しください。
note.com

ではでは、この辺で(^^)/~~~

特定のフォルダ内からすべての「サブフォルダ名」、「ファイル名」を取得する方法

FileSystemObjectを使って、特定のフォルダからすべての「サブフォルダ」、「ファイル」を取得する

最終更新日：2022/7/1

以下のようなフォルダが存在します。

フォルダがA、B、C、Dの４つ、
ファイルがDSC_0002.JPG、FSO.xlsmの２つあります。

これをFSO.xlsmからFileSystemObjectでフォルダ名、ファイル名取得するコードを記載します。

フォルダ名の取得

ファイル名の取得

フォルダ名を取得するコード

Option Explicit

Sub フォルダ名の取得_1()
    
    Dim fso As Object: Set fso = CreateObject("scripting.filesystemobject")
    Dim myPath
    Dim myFile
    
    myPath = ThisWorkbook.Path
    
    Dim myFolder
    For Each myFolder In fso.GetFolder(myPath).SubFolders
        Debug.Print myFolder.Name
    Next

End Sub

「For Each myFolder In fso.GetFolder(myPath).SubFolders」でmyPathのSubFolders（フォルダを取得します。）

処理結果は以下のように、イミディエイトウィンドウに書き出されます。

ファイル名の取得するコード

Option Explicit

Sub ファイルの取得_2()
    
    Dim fso As Object: Set fso = CreateObject("scripting.filesystemobject")
    Dim myPath
    Dim myFile
    
    myPath = ThisWorkbook.Path
    
    
    For Each myFile In fso.GetFolder(myPath).Files
        Debug.Print myFile.Name
    Next
    
    Set fso = Nothing

End Sub

処理結果は以下のように、イミディエイトウィンドウに書き出されます。

「For Each myFile In fso.GetFolder(myPath).Files」でmyPathのFiles（ファイル）を取得します。

感想

ファイル名の取得は、「fso.GetFolder(myPath).Files」とコードを見て分かったのですが、
フォルダ名の取得は、「 fso.GetFolder(myPath).SubFolders」というコードで、Forlderじゃないんかい！！と思いましたｗ。

しかしよく考えると、ｗrokがFolderで、その中にあるABCDは、workフォルダ内のサブフォルダーになるのか！と気づきました。

ＦＳＯまだまだ理解が足りてません(;^ω^)

備忘録でした(^^)/~~~

VBA100本ノック 41本目：暗算練習アプリ

この記事から得るもの

乱数の作り方。
ランダムに演算子を選んで、計算する方法。

目次
　 １　今回のお題
　 ２　今回のお題の意図
　 ３　回答
　 ４　感想　
　 ５　英語の勉強　

１　今回のお題

暗算練習アプリを作成します。
・整数2個と+-*/の演算子をランダムに選ぶ
・問題をInputBoxに表示
・入力値を採点
・全10問、最後に10点満点で点数をMsgBox表示
・キャンセルや未回答は次の問題に進む
※整数の範囲については暗算できる範囲で随意
※添付GIFを参考に

excel-ubara.com

２　今回のお題の意図

計算用の変数を乱数で２つ取得する。
演算子を選択する（＋、ー、＊、/）。
計算する
１０回繰り返す。

３　回答

アプリ開発的なお題なので作成までの過程を記述していきます。

１　乱数を取得する。

０～９の乱数を取得する手順。

１　Rnd関数で0以上1未満のランダムな小数を取得する。
２　少数を１０倍する。
３　Int関数で整数部分を抜き出す。

コードで表現すると、

operator = Int(Rnd * 10)

変数operatorに０～９の乱数を取得します。

２　演算子を選択する。

Select Caseで処理パターンを決めることにしました。
変数operatorが０～３で場合分けします。

'計算する数字を乱数で求める。
operatorNo1 = Int(Rnd * 100): operatorNo2 = Int(Rnd * 100)

'演算子の場合分け
Do
    operator = Int(Rnd * 10)
Loop Until operator < 4

Select Case operator
    Case Is = 0
        Anser= operatorNo1 + operatorNo2
        operatorString = operatorNo1 & " + " & operatorNo2
        
    Case Is = 1
        Anser = operatorNo1 - operatorNo2
        operatorString = operatorNo1 & " - " & operatorNo2
        
    Case Is = 2
        Anser = operatorNo1 * operatorNo2
        operatorString = operatorNo1 & " * " & operatorNo2
        
    Case Is = 3
        Anser = operatorNo1 / operatorNo2
        operatorString = operatorNo1 & " / " & operatorNo2
        
End Select

３　計算結果を受け取る

Inputbox関数を使います。
変数にInputboxに入力した値を代入する際は、Inputboxを（）でくくります。

myAnser = InputBox(i & "問目" & String(2, vbCrLf) & operatorString, "暗算練習")

変数myAnserに、Inputboxに入力した値（解答）を代入します。

変数myAnser（解答）と変数Anser（答え）を比較します。

これを１０回繰り返します。

私の回答

Sub ノック41本目_1()
Dim Anser(1 To 10) As Integer: Dim myAnser(1 To 10) As Integer

For i = 1 To 10

'計算する数字を乱数で求める。
operatorNo1 = Int(Rnd * 100): operatorNo2 = Int(Rnd * 100)


'演算子の場合分け----------------------------------------------------
Dim operator As Byte

Do
    operator = Int(Rnd * 10)
    
    On Error Resume Next
    
    '割り算の場合は整数になる数字を求める
    If operator = 3 Then
        If operatorNo1 Mod operatorNo2 <> 0 Then
            Do
                operatorNo1 = Int(Rnd * 100): operatorNo2 = Int(Rnd * 100)
                
            Loop Until operatorNo1 Mod operatorNo2 = 0
        End If
    End If
Loop Until operator < 4
'____________________________________________________________________


Select Case operator
    Case Is = 0
        Anser(i) = operatorNo1 + operatorNo2
        operatorString = operatorNo1 & " + " & operatorNo2
        
    Case Is = 1
        Anser(i) = operatorNo1 - operatorNo2
        operatorString = operatorNo1 & " - " & operatorNo2
        
    Case Is = 2
        Anser(i) = operatorNo1 * operatorNo2
        operatorString = operatorNo1 & " * " & operatorNo2
        
    Case Is = 3
        Anser(i) = operatorNo1 / operatorNo2
        operatorString = operatorNo1 & " / " & operatorNo2
        
End Select


myAnser(i) = InputBox(i & "問目" & String(2, vbCrLf) & operatorString, "暗算練習")

Next


'正解数確認
correctAnswerCount = 0

For j = 1 To 10
    If Anser(j) = CInt(myAnser(j)) Then
        correctAnswerCount = correctAnswerCount + 1
    End If
Next

MsgBox "１０問中、" & correctAnswerCount & "問正解です。"
        
End Sub

配列変数Anser()、myAnser()に問題の答えと回答を書込みます。
正解数確認で答え合わせをします。
割り算の問題では、割り切れないものは再度乱数を取り直します。
難点としては、解答が０の場合未回答でも正解になってしまうことです(;^ω^)。

４　感想

乱数の作り方は知っているようでちゃんと理解していませんでした。
５８＊４２とか出るんですが、暗算できません(;^ω^)。
便利な頭の体操アプリがエクセルでできてしまうんですね！

ではでは、この辺で(^^)/~~~

５　英語の勉強

演算子：operator

Book内に特定の名前のSheet名が存在するかスマートに調べる方法

Book内に特定の名前のSheetが存在するか調べるには…

私が最初に思いつくのは、For each in Sheetsで、シートをループして特定の名前があるかを調べるです。

Sub Sheet名が存在するか調べる()

'Sheetに”2020年12月”があるか調べる。
For Each sh In Sheets
    shCount = shCount + 1
    shCounts = Sheets.Count
    
    'Bookが１回目の書込み処理
    If sh.Name = "2020年12月" Then
        MsgBox "2020年12月は存在します"
    
    Else
        '"2020年12月"のSheetが無い場合
        If shCount = Sheets.Count Then
            MsgBox "2020年12月は存在しません"
            
        End If
    End If
Next

End Sub

力ずくな感じですね(;^ω^)
VBA100本ノックをやってる中で、サイト管理者のコードを見ていてこれは便利だ！というのがあったので、備忘録として記録しておきます。

スマートなSheet名存在するか調べるコード

Sub BookにSheetが存在するかどうか()

Const shtName = "2020年12月"

Dim wbT As Workbook, wsT As Worksheet
Dim sFile As String: sFile = "A.xlsx"

myPath = ThisWorkbook.Path & "\40本目\data\"

Set wbT = Workbooks.Open(Filename:=myPath & sFile, UpdateLinks:=0, ReadOnly:=True)
Set wsT = getWorksheet(wbT, shtName)

If Not wsT Is Nothing Then
    MsgBox shtName & "は存在します｡"
Else
    MsgBox shtName & "は存在しません｡"
End If

End Sub

Function_getWorksheet

Function getWorksheet(ByVal wb As Workbook, ByVal aName As String) As Worksheet
    On Error Resume Next
    Set getWorksheet = wb.Worksheets(aName)
End Function

これは、特定のフォルダに存在するA.xlsxのBookを開いて、Sheet名に「2020年12月」があるかどうかを調べます。

特定のファルダの.xlsxファイルに特定のSheet名が含まれるか調べる方法

Sub ファイル内のSheetが存在するかどうか()

Const shtName = "2020年12月"

Dim wbT As Workbook, wsT As Worksheet
Dim sFile As String

myPath = ThisWorkbook.Path & "\40本目\data\"

sFile = Dir(myPath & "*.xlsx")

'主処理
Do While sFile <> ""
    Set wbT = Workbooks.Open(Filename:=myPath & sFile, UpdateLinks:=0, ReadOnly:=True)
    Set wsT = getWorksheet(wbT, shtName)
    
    If Not wsT Is Nothing Then
        MsgBox shtName & "は存在します｡"
    Else
        MsgBox shtName & "は存在しません｡"
    End If
    
    wbT.Close SaveChanges:=False　　'Bookを閉じる
 
    sFile = Dir()   '次のファイルへ移動
Loop

End Sub

Dir関数で.xlsxファイルのみを取得し、Do Loopで特定のSheet名があるかを判定します。
どうでしょうか？Function（getWorksheet）でSetできたかどうかでSheet名が存在するかを調べることができます。
便利だなと思ったので、備忘録です。

ではではこの辺で(^^)/~~~

VBA100本ノック 40本目：複数ブックの統合

この記事から得るもの

他のBookへのCopy、Pasteする方法。
FSOを使用して、ファイルを開く。
Range．CurrentRegionの見出しを除いたデータをCopy、Pasteする方法。

目次
　 １　今回のお題
　 ２　今回のお題の意図
　 ３　回答
　 ４　感想　

１　今回のお題

「data」フォルダ内のExcelファイルについて、シート「2020年12月」のA1からの連続表範囲を集めます。※このシートが無いファイルもある。
自身の既存シート「2020年12月」に集めてください。
1行目は見出しなので2件目からは除く。
※ブック指定と「data」のパス位置は任意

excel-ubara.com

２　今回のお題の意図

１　該当するSheetが存在するかの確認。
２　最初のコピー時には見出しもコピーする。

３　回答

私の最初の回答

Sub ノック40本目_1()

'FSOを宣言
Dim fso_lord As Object: Set fso_lord = CreateObject("scripting.filesystemobject")

'pathの設定
wbPath = ThisWorkbook.Path & "\40本目\"

'ファイルをmyfilesにSetする。
Dim myfiles As Object: Set myfiles = fso_lord.getfolder(wbPath).Files

'主処理
Dim bookCount As Integer: bookCount = 0: Dim file As Object

For Each file In myfiles
    If Not file.Name Like "~$*" Or file.Name Like ".xlsx" Then
        'ファイルを開く
        Workbooks.Open wbPath & file.Name
        
        'Sheetに”2020年12月”があるか調べる。
        For Each sh In Sheets
            shCount = shCount + 1
            shCounts = Sheets.Count
            
            'Bookが１回目の書込み処理
            If sh.Name = "2020年12月" And bookCount = 0 Then
                Worksheets(sh.Name).Select
                ActiveSheet.Range("A1").CurrentRegion.Copy
                
                'ファイルを閉じる
                Application.DisplayAlerts = False
                ActiveWorkbook.Close
                Application.DisplayAlerts = True
                
                ActiveSheet.Paste Destination:=Range("A1")
                
                bookCount = bookCount + 1
                Exit For
            
            'Bookが２回目以降の書込み処理
            ElseIf sh.Name = "2020年12月" And bookCount > 0 Then
                Worksheets(sh.Name).Select
                ActiveSheet.Range("A1").CurrentRegion.Offset(1, 0).Copy
                
                'ファイルを閉じる
                Application.DisplayAlerts = False
                ActiveWorkbook.Close
                Application.DisplayAlerts = True
                
                '最終行を取得
                lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
                ActiveSheet.Paste Destination:=Range("A" & lastRow)
                
                bookCount = bookCount + 1
                Exit For
                
            Else
                '"2020年12月"のSheetが無い場合はBookを閉じる。
                If shCount = Sheets.Count Then
                    'ファイルを閉じる
                    Application.DisplayAlerts = False
                    ActiveWorkbook.Close
                    Application.DisplayAlerts = True
                End If
            End If
        Next
        
        '初期化
        shCount = 0
        
    End If
Next

End Sub

FSOを使って、フォルダをループします。
対象のBookが見つかったらBookを開いて、Copyした後に他のBookに貼り付ける手段がわからず、Copyして強制的に閉じる（クリップボードにデータは残っている）。その後、貼り付け元のSheetをActiveSheetとして貼り付けています。これに関してはもっといい方法がありそうです。

他のBOOKへのCopy ＆　Pasteについて

Sub copypaste()

'参考のコード
'wsT.Range("A1").CurrentRegion.Offset(offsetRow).Copy ws.Cells(outRow, 1)

Workbooks("A.xlsx").Worksheets("2020年12月").Range("A1").CurrentRegion.Copy Workbooks("40本目.xlsm").Worksheets("2020年12月").Range("A1")

End Sub

サイト管理者のコードを参考に記述してみました。
なるほど、他のBookへCopy ＆ Pasteするときは、「Workbook．Worksheet．Range」を指定してあげないといけないのですね。
こういう基本的な部分がまだまだ甘い(;^ω^)

私の最終回答

Sub ノック40本目_2()

Const SheetName = "2020年12月"

Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(SheetName)

'書込み先データの削除
wb.Worksheets(SheetName).Cells.Clear

'FSOを宣言
Dim fso_lord As Object: Set fso_lord = CreateObject("scripting.filesystemobject")

'pathの設定
wbPath = ThisWorkbook.Path & "\40本目\data\"

'ファイルをmyfilesにSetする。
Dim myfiles As Object: Set myfiles = fso_lord.getfolder(wbPath).Files

'主処理
Dim bookCount As Integer: bookCount = 0: Dim file As Object

For Each file In myfiles
    If Not file.Name Like "~$*" Or file.Name Like ".xlsx" Then
        'ファイルを開く
        Workbooks.Open wbPath & file.Name
        
        'Sheetに”2020年12月”があるか調べる。
        For Each sh In Sheets
            shCount = shCount + 1
            shCounts = Sheets.Count
            
            'Bookが１回目の書込み処理
            If sh.Name = "2020年12月" And bookCount = 0 Then
                Worksheets(sh.Name).Select
                ActiveSheet.Range("A1").CurrentRegion.Copy ws.Range("A1")
                
                'ファイルを閉じる
                ActiveWorkbook.Close SaveChanges:=False
                
                '処理済みBook数をインクリメント
                bookCount = bookCount + 1
                Exit For
            
            'Bookが２回目以降の書込み処理
            ElseIf sh.Name = "2020年12月" And bookCount > 0 Then
                Worksheets(sh.Name).Select
                
                '最終行を取得して貼り付け
                lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
                ActiveSheet.Range("A1").CurrentRegion.Offset(1, 0).Copy ws.Range("A" & lastRow)
                
                'ファイルを閉じる
                ActiveWorkbook.Close SaveChanges:=False
                
                '処理済みBook数をインクリメント
                bookCount = bookCount + 1
                Exit For
                
            Else
                '"2020年12月"のSheetが無い場合はBookを閉じる。
                If shCount = Sheets.Count Then
                
                    'ファイルを閉じる
                    ActiveWorkbook.Close SaveChanges:=False
                End If
            End If
        Next
        
        '初期化
        shCount = 0
        
    End If
Next


End Sub

Copy、Pasteを簡潔に記述しました。変数wsにBook名とSheet名をSetしておけば、楽にPaste時に使用できます。
ファイルを閉じる処理も、「SaveChanges:=False」を加えることで、Application.DisplayAlertsをいじる必要もなくなります。

４　感想

今回もかなり勉強になりました。他のBookへCopy、Pasteする方法は知っておかないといけないですね(;^ω^)
「Range（”A1”）．CurrentRegion.Offset(1, 0).Copy」で見出しを除いたデータ部をCopyする方法もかなり便利です。

ひとつ気になったのは、定数で指定している”2020年12月”は大文字の可能性もあるので、strconv関数で半角文字にしてしてあげるとよりよいのかなと思いました。

ではでは、この辺で(^^)/~~~