cr（カレントリージョン）で、列データの種類ごとに小計を取る。

cr（カレントリージョン）を条件分岐して取得する。

crは条件分岐して取得することができます。今回は、預金者区分１，２，３、の3種類のcrを作ってそれぞれの小計を出します。

目次
　 １　閲覧対象者
　 ２　得られる効果
　 ３　演習問題
　 ４　コードの解説　
　 ５　とある信用金庫さんへの悩みを解決する　
　 ６　感想

１　閲覧対象者

cr（カレントリージョン）を条件分岐で取得する方法を、マスターしたい人。

２　得られる効果

条件設定して得られたRangeを簡単に操作できます。

３　演習問題

以下のような表があります。

演習問題
・この表からA列の預金者区分１，２、３ごとに小計だしてください。

ポイントは、３つのRangeを宣言してそれぞれに範囲を取って合計を出すことです。
では、次の章の回答コードを見ていきましょう。

４　コードの解説

回答コード

Sub cr_Subtotal()

    Dim cr As Range: Set cr = Range("A1").CurrentRegion
    Dim i As Long
    Dim targetRange1 As Range, targetRange2 As Range, targetRange3 As Range
    Dim taget1_Subtotal, taget2_Subtotal, taget3_Subtotal
    
    For i = 2 To cr.Rows.Count
        '預金者区分１
        If cr.Cells(i, 1) = 1 Then
            If targetRange1 Is Nothing Then
                Set targetRange1 = cr.Rows(i)
            Else
                Set targetRange1 = Union(targetRange1, cr.Rows(i))
            End If
            
        '預金者区分２
        ElseIf cr.Cells(i, 1) = 2 Then
            If targetRange2 Is Nothing Then
                Set targetRange2 = cr.Rows(i)
            
            Else
                Set targetRange2 = Union(targetRange2, cr.Rows(i))
            End If
        
        '預金者区分３
        ElseIf cr.Cells(i, 1) = 3 Then
            If targetRange3 Is Nothing Then
                Set targetRange3 = cr.Rows(i)
            
            Else
                Set targetRange3 = Union(targetRange3, cr.Rows(i))
            End If
        End If
    Next
    
    '小計を取得する。
    If Not targetRange1 Is Nothing Then taget1_Subtotal = WorksheetFunction.Sum(targetRange1.Columns(3))
    If Not targetRange2 Is Nothing Then taget2_Subtotal = WorksheetFunction.Sum(targetRange2.Columns(3))
    If Not targetRange3 Is Nothing Then taget3_Subtotal = WorksheetFunction.Sum(targetRange3.Columns(3))
    
    Debug.Print taget1_Subtotal
    Debug.Print taget2_Subtotal
    Debug.Print taget3_Subtotal
        
End Sub

まず、区分が１、２、３と３つ存在するのでtargetRangeを３つ用意します（targetRange１～targetRange３）。
cr（カレントリージョン）のA列が１の場合は、targetRange１に範囲をSetします。
cr（カレントリージョン）のA列が２の場合は、targetRange２に範囲をSetします。
cr（カレントリージョン）のA列が３の場合は、targetRange３に範囲をSetします。
targetRange1 がNothingでない場合、targetRange１の預金額を合計します（Columns(3)が預金額欄です）。
targetRange２がNothingでない場合、targetRange２の預金額を合計します（Columns(3)が預金額欄です）。
targetRange２がNothingでない場合、targetRange３の預金額を合計します（Columns(3)が預金額欄です）。
Debug.Printでそれぞれ値を出します。

Debug.Printの出力結果

期待通りの小計が取得できていることが確認できます。

５　とある信用金庫さんへの悩みを解決する

もう一度、処理対象の表を確認します。

次の条件でcrから範囲を取得します。
１　預金金額は１以上
２　預金額が3000円の場合は除く

ではコードに落とし込んでいきましょう！

Sub cr_Subtotal2()

    Dim cr As Range: Set cr = Range("A1").CurrentRegion
    Dim i As Long, myRnge As Range
    Dim targetRange1 As Range
    Dim taget1_Subtotal
    Dim rangeCount As Long
    
    For i = 2 To cr.Rows.Count
        '預金額が１以上
        If cr.Cells(i, 3) > 1 Then
            '預金額が3000円で無い場合
            If Not cr.Cells(i, 3) = 3000 Then
                If targetRange1 Is Nothing Then
                    Set targetRange1 = cr.Rows(i)
                Else
                    Set targetRange1 = Union(targetRange1, cr.Rows(i))
                End If
            End If
        End If
    Next
    
    '3000円の列以外が選択できていることが確認できる。
    targetRange1.Select
    
    '小計を取得する。
    If Not targetRange1 Is Nothing Then: taget1_Subtotal = 0
        For Each myRnge In targetRange1
            rangeCount = rangeCount + 1
            If rangeCount = 3 Then
                taget1_Subtotal = taget1_Subtotal + myRnge.Value
                rangeCount = 0
            End If
        Next
    
    Debug.Print taget1_Subtotal

End Sub

IF文で預金額が１以上かつ、3000円以上の場合、targetRange1にSetします。
targetRange1.Selectで、3000円以外のセルが選択できていることが確認できます。
小計は、ごめんなさいSumで簡単に取れなかったので、苦肉の策で「For　each　in　next」でループして、変数rangeCount ＝３（預金額のデータの時）に変数taget1_Subtotal に預金額を足して小計を出しています。もっとスマートな方法は考えておきますm(_ _"m)。

Debug.Printの結果

きちんと3000円以外の小計が取れています。ちなみに、変数taget1_Subtotal はVariant型にしてます。Long型でもオーバーフローするとのことだったので。

ちなみに、targetRange1.Selectをした時の画像↓↓

預金額が3000円以上の行が選択されています。

改良版

改良コード↓↓

Sub cr_Subtotal2_Ver2()

    Dim cr As Range: Set cr = Range("A1").CurrentRegion
    Dim i As Long, myRnge As Range
    Dim targetRange1 As Range, targetCountRange1 As Range
    Dim taget1_Subtotal
    Dim rangeCount As Long
    
    For i = 2 To cr.Rows.Count
        '預金額が１以上
        If cr.Cells(i, 3) > 1 Then
            '預金額が3000円で無い場合
            If Not cr.Cells(i, 3) = 3000 Then
                If targetRange1 Is Nothing Then
                    Set targetRange1 = cr.Rows(i)
                    Set targetCountRange1 = cr.Cells(i, 3)
                Else
                    Set targetRange1 = Union(targetRange1, cr.Rows(i))
                    Set targetCountRange1 = Union(targetCountRange1, cr.Cells(i, 3))
                End If
            End If
        End If
    Next
    
    '3000円の行以外の列Cが選択できていることが確認できる。
    targetCountRange1.Select
    
    '条件にあった預金額の小計を取る。
    If Not targetRange1 Is Nothing Then taget1_Subtotal = WorksheetFunction.Sum(targetCountRange1)
    
    Debug.Print taget1_Subtotal

End Sub

変数targetCountRange1 を追加しました。これは、預金額の部分のみの範囲を取得します。
よって、変数taget1_Subtotal にSum関数で一発で小計が取得できます。
少しだけスマートになりました！

６　感想

いや～、複数のcrを選択した場合、cr.Rows.Count＝２になってしまうことに気づきました(;^ω^)
行１３まで選んでくれると思ったら、途切れたセルの範囲は取得してくれませんでした(´;ω;｀)
とりあえず、やっつけで「For　each　in　next」作ってみました。
とある信用金庫さん、参考にならなかったらすんませんm(_ _"m)
crの極意をもっと勉強します。

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

cr（カレントリージョン）で、2つおきの行を削除する。

cr（カレントリージョン）の普及活動！

cr（カレントリージョン）って何？と思われるでしょう。一言でいうと、セルの範囲操作が容易になります。
この記法は「ほえDX塾」で教わったものです。ブログへの記載ＯＫということなので、この便利さを伝えたいなと思います。
気が向いたら、シリーズ化します。

目次
　 １　閲覧対象者
　 ２　得られる効果
　 ３　演習問題
　 ４　コードの解説　
　 ５　2行おきのデータを削除する　
　 ６　感想

１　閲覧対象者

crの記法を学んで、セルの範囲操作の幅を広めたい人。

２　得られる効果

セルの範囲（Range）を簡単に操作することができる。

３　演習問題

以下のような表があります。

演習問題
・この表から２つおきの行を選択してください。

正直、この問いへの答えが出せませんでした。For Nextでループさせても、Selectしたままにできんな～(;^ω^)とお手上げでした。
そんなときcr（カレントリージョン）がすごく便利なのです。久々にコードを見て感動しました。

ちなみにこの問いに対する正解は、以下の画像の状態です。

２，４，６、～１２の行を選択します。ここまでみなさんは回答のコードを作れますか？
ではでは、回答のコードは次の章です。

４　コードの解説

Sub cr_Union()

    Dim cr As Range: Set cr = Range("A1").CurrentRegion
    Dim i As Long
    Dim myRange As Range
    
    For i = 2 To cr.Rows.Count Step 2
        If i = 2 Then
            If myRange Is Nothing Then
                Set myRange = cr.Rows(i)
            End If
            
        Else
            Set myRange = Union(myRange, cr.Rows(i))
        End If
    Next
    
    myRange.Select
        
End Sub

変数crにRange("A1").CurrentRegionの範囲をセットします。
初期値２で「For　next　Step 2」でループ処理します。
変数myRangeにcrの行を格納していきます。ポイントは、myRangeの初期状態は「Nothing」となっているので、1回目のSetで範囲を設定するときはNothingかどうかの判定が必要です。
2回目以降は、myRangeに「Union(myRange, cr.Rows(i))」で追加格納していきます。
このようにして、2行おきのデータを格納していきます。
そして、最後の「myRange.Select」で選択します。

これが問題の回答コードとなります。

５　2行おきのデータを削除する

ここからは、crを応用した処理です。

crからmyRangeでセルを選択できました。次に、myRangeを削除してみましょう。削除するには、以下のコードです。

Sub cr_Union()

    Dim cr As Range: Set cr = Range("A1").CurrentRegion
    Dim i As Long
    Dim myRange As Range
    
    
    For i = 2 To cr.Rows.Count Step 2
        If i = 2 Then
            If myRange Is Nothing Then
                Set myRange = cr.Rows(i)
            End If
            
        Else
            Set myRange = Union(myRange, cr.Rows(i))
        End If
    Next
    
    myRange.Select
    myRange.Delete
        
End Sub

「myRange.Delete」を追加するだけです。

処理した状態が以下の画像です。

myRangeの範囲のデータが削除されます。
普通、2行おきのデータを削除するというと「For　next　Step －１」でDeleteしていくのではないでしょうか？
しかし、crを使えば指定の範囲を分かりやすいイメージで削除できます。

６　感想

いかがだったでしょうか？セルの範囲選択といっても奥が深いと思いました。cr（カレントリージョン）を使うことで指定の範囲への操作が容易となります。
次回は、複数のmyRangeを取得して並び替える処理について記事を書こうと思います。

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

ウェブページを表示するコントロールWebBrowserの表示を方法。表示のさせ方。

ユーザフォーム上でGoogleを検索ができる

上の写真の様に、ユーザフォーム上にGoogleを表示できます。ユーザフォームの中で検索もできます。
いや、Chrome開けよ！って話なんですが。なんか面白いので記事にしてみました。

目次
　 １　閲覧対象者
　 ２　得られる効果
　 ３　WebBrowserをユーザフォームコントロールに表示する
　 ４　WebBrowserコントロールを使ってみよう！　
　 ５　WebBrowserコントロールにGoogleを表示する　
　 ６　まとめ
　 ７　
　 ８　

１　閲覧対象者

ユーザフォーム上で、Chromeを開いて検索したい方。

２　得られる効果

Chromoeを直に開かなくてよい。

３　WebBrowserをユーザフォームコントロールに表示する

以下の画面の蛍光線部が、WebBrowserコントロールです。しかし、デフォルトでは表示されません。
まずは表示方法から、解説します。

１　ツールボックス_コントロールの確認

以下の画像の通り、WebBrowserコントロールはありません。では、追加していきましょう！

２　WebBrowserコントロールの追加

以下の画像の通り、ツールボックス_コントロールを右クリックします。すると、その他のコントロールと出るので、クリックします。

すると、以下のようなコントロールの追加画面が出てきます。ここで、「Microsoft Web Browser」にチェックを入れ追加します。

こうすることで、ツールボックスの中に「WebBrowserコントロール」を選択できるようになります。

４　WebBrowserコントロールを使ってみよう！

では、実際にWebBrowserコントロールを配置してみましょう！
WebBrowserコントロールを配置すると、以下の画像の様に真っ暗な画面になります。少々不安になりますが、これでOK！

では、UserForm_Initialize処理時にWebBrowserコントロールに「Googleを表示」するように設定しましょう！

５　WebBrowserコントロールにGoogleを表示する

コードは超絶簡単です。UserForm_Initializeの中に以下のコードを書き込みます。

Private Sub UserForm_Initialize()

    WebBrowser1.Navigate "https://www.google.co.jp/"

End Sub

こんだけです。では、標準モジュールにUserForm1.Showの処理を追加して実行すると以下の通り。

何ということでしょう。ユーザーフォーム上にGoogleが表示されました。しかも、普通にこの中で検索できます。
以下の画像の通り、入力します（宣伝ｗ）。

Enterで検索すると、以下の画像の通り。何と言いうことでしょう、吾輩のブログがでてきました（宣伝ｗ）。

ちなみに、戻るボタンが表示されないのでその辺はショートカットキー「Alt＋←」で検索画面に戻りましょう！

６　まとめ

いかがだったでしょうか。ユーザーフォーム上にWebブラウザを表示できるという感動はありつつも、Chrome開けばよくね？という正論の狭間にある心境です(;^ω^)。

しかし、IEコントロールで中の動きを制御できるみたいなので、Webスクレイピングの幅が広がったりするのか？。そんな期待感もあります。

この手の情報は、バスっとネットに転がってないんですよね。なんかいい記事みつけたら随時更新していきます。

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

全てのサブフォルダのファイル名を変更する。

全てのサブフォルダのファイル名を変更する

設計書のドキュメントファイルを自動生成する野良マクロと遭遇しました。怒りを覚えたが、お仕事なので解読しましたｗ。
その処理の中で、ドキュメント生成ができたら普通のファイル名、出来なければファイル名の頭に”×”が付きます。
１０ファイルくらいならいいのですが、１００ファイルを超えるとやってられないですよね。
なので、すべてのサブフォルダのエクセルファイル名を変更するコードを考えました。

目次
　 １　自動生成されたファイルの例
　 ２　実際のコード
　 ３　処理結果

１　自動生成されたファイルの例

以下の画像のようなファイル構成があります。

以下の画像のように、ファイルA、ファイルBの中に先頭に×が付いているファイルと、付いていないファイルがあります。

×が付いているファイルを、編集後に×を取ります。×がついたファイルが数百ファイルも有ったらやってられないですよね。
では、ピョログラミングでハムハムしましょう！

２　実際のコード

Sub サブフォルダのファイル名を更新する()

    Dim fso As Object: Set fso = CreateObject("scripting.filesystemobject")
    Dim myPath As String: myPath = ThisWorkbook.Path
    
    Dim targetPath As String
    Dim oldName As String
    Dim newName As String
    
    Dim myFolder As Variant
    For Each myFolder In fso.GetFolder(myPath).SubFolders
        
        targetPath = ThisWorkbook.Path & "\" & myFolder.Name
        
        Dim myFile As Variant
        For Each myFile In fso.GetFolder(targetPath).Files
            
            oldName = myFile.Name
            
            'ファイル名の頭に×があれば、MIDで×を除いたファイル名にする。
            If Mid(oldName, 1, 1) = "×" Then
                newName = Mid(oldName, 2)
                
                oldName = targetPath & "\" & oldName
                newName = targetPath & "\" & newName
                
                'ファイル名の変更（Nameステートメント）
                Name oldName As newName
            End If
        Next
    Next

End Sub

FSOと、Nameステートメントを使います！

３　処理結果

下の画面の通り、ファイル名から×が取れております。

ファイル名を変更する「Name」ステートメント、ＶＢＡ９年目にして初めて知りました。まだまだ奥が深いですＶＢＡ。

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

サブフォルダーのファイルを取得するVBA

サブフォルダーのファイルまで取得するＶＢＡ

仕事が超絶楽になるはずだよ！

目次
　 １　作成の経緯
　 ２　コードを記載
　 ３　感想

１　作成の経緯

ドキュメントの一括作成を迫られたのでｗ

２　コードを記載

以下のようにファイルA、B、C、Dのフォルダがあります。

以下のようにフォルダの中にエクセルファイルが入っています。

サブフォルダーを取得する実際のコード

Sub サブフォルダのファイルまで取得する()

    Dim fso As Object: Set fso = CreateObject("scripting.filesystemobject")
    
    Dim varTmp As Variant
    Dim myFolser As String
    
    
    Dim targetPath As String
    Dim targetSubPath As String
    
    Dim files As Variant
    Dim file As Variant
    Dim myFile As Variant
    
    targetPath = ThisWorkbook.Path
    
    For Each varTmp In fso.GetFolder(targetPath).SubFolders
    
        'Debug.Print varTmp.Name
            
        targetSubPath = targetPath & "\" & varTmp.Name
        
        Set files = fso.GetFolder(targetSubPath)
        Set file = files.files
        
        For Each myFile In file
            Debug.Print myFile.Name
        Next
    Next
    
    Set fso = Nothing

End Sub

処理結果

３　感想

fsoを作って、サブフォルダを取得してイミディエイトウィンドウに出力しているだけです。
For Each myFile In fileの処理の中で、すべてのサブフォルダのファイルを処理できます！
いつでも、どこかで使えそう！

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

ドキュメント自動生成ひな形

作成途中

Option Explicit

Sub すべてのファイルに値を代入()

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

Dim Input_wb As Workbook
Dim Input_LastLline As Long
Dim Output_Path As Variant


Dim mySh As Worksheet

Dim Item1 As String
Dim Filename As String


'pathの設定
wbPath = ThisWorkbook.Path & "\INPUTファイル\"

Set myfiles = fso_lord.getfolder(wbPath).Files
    
For Each file In myfiles
    If Not file.Name Like "~$*" Or file.Name Like ".xlsx" Then
        Call OpenBooks_String(wbPath & file.Name)
        Set Input_wb = ActiveWorkbook
        
        
        Workbooks.Add
        Filename = "成果物1"
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\成果物\" & Filename
        Output_Path = ActiveWorkbook.Name
        
        
        'ブック間のデータのやり取り！
        Workbooks(file.Name).ActiveSheet.Range("A1").Copy Workbooks(Output_Path).Sheets(1).Range("A1")
        
        
'        Workbooks(file.Name).Activate
'        Sheets("INPUT_ITEM").Range("A1").Copy
'
'        Workbooks(Output_Path).Activate
'        Range("A1").PasteSpecial Paste:=xlPasteValues
'
        
        
        
        
        '対象のSheetを探す処理
        For Each mySh In Input_wb.Worksheets
            
            '特定のsheetを処理する
            If mySh.Name = "INPUT_ITEM" Then
                
                Item1 = mySh.Range("A2")
                
                MsgBox mySh.Name
            
            End If
            
        
        Next
        
    
        
        '転記する処理
        Workbooks.Add
        
        
        Call CloseBooks_Sring(file.Name)
    End If
Next


End Sub


Sub OpenBooks_String(ByVal mypath As String)
    
Workbooks.Open mypath
'Range("A1").Value = "自動で開きました。"

End Sub


Sub CloseBooks_Sring(ByVal myName As String)
    
Dim wb As Workbook
Set wb = Workbooks(myName)

wb.Close (True)

End Sub

ファイルの結合の項目チェックをするVBA！

ファイルの項目がInputファイル、outputファイルに存在するかを調べる

INPUTファイルから、OUTPUTファイルを作りますよね。それなのに、OUTPUTファイルの項目に、INPUTファイルの項目が無いという現実(´;ω;｀)。
こんな事態を打破すべく、ExcelＶＢＡでチェックツールを作りました。

目次
　 １　閲覧対象者
　 ２　得られる効果
　 ３　設計
　 ４　コードの解説　
　 ５　感想　

１　閲覧対象者

INPUTファイルとOUTPUTファイルの項目名が違うとお怒りの方ｗ

２　得られる効果

OUTPUTファイルにINPUTファイルの項目が無いものを特定できる！

３　設計

１　以下の写真の通り、2つのINPUTファイルから１つのUnionファイル（OUTPUTファイル）を作成します。

２　以下の写真の通り、マクロ「結合比較を実施します」

３　以下の写真の通り、列Ｆ「判定」にINPUTファイルに含まれるものは「項目有」と表示される。空白のものが、INPUTファイルに項目が無いものとなる。

４　コードの解説

＜マクロ結合比較のコード＞

Sub 結合比較()

    Dim ws As Worksheet: Set ws = Worksheets("結合比較")
    
    Dim input1 As Long: input1 = ws.Cells(Rows.Count, 1).End(xlUp).Row
    Dim input2 As Long: input2 = ws.Cells(Rows.Count, 3).End(xlUp).Row
    Dim Union_output As Long: Union_output = ws.Cells(Rows.Count, 5).End(xlUp).Row
    
    Dim serchItem As String
    Dim compItem As String
    Dim endFlg As Boolean
    
    
    'inputファイル１を探す
    Dim k_serchItem As Long
    For k_serchItem = 2 To Union_output
        endFlg = False
        serchItem = ws.Cells(k_serchItem, 5)
        
        Dim k_input1 As Long
        For k_input1 = 2 To input1
            compItem = ws.Cells(k_input1, 1)
            
            If serchItem = compItem Then
                ws.Cells(k_serchItem, 6) = "項目有"
                endFlg = True
                Exit For
            End If
            
        Next
        
        
        'inputファイル１に無い場合、Input２を探す
        If endFlg = False Then
            Dim k_input2 As Long
            For k_input2 = 2 To input2
                compItem = ws.Cells(k_input2, 3)
                
                If serchItem = compItem Then
                    ws.Cells(k_serchItem, 6) = "項目有"
                    endFlg = True
                    Exit For
                End If
            Next
        End If
    Next
    
End Sub

単純なコードです。
For～NEXTでファイル１を検索し、その次にファイル２を検索する。
項目があれば、列Ｆに”項目有”と表示して、endFlgをTrueにする。この処理を繰り返す。

５　感想

この設計の場合、２つのファイルから１つのOUTPUTファイルを作る場合に限定されてしまします(;^ω^)。
３つのファイルから、２つのファイルを作るなどには対応していません。
そこらへんは改良が必要ですが、取り急ぎ業務改善に必要なコードを作ってみました。
私も別のパータンが出てきたら、改良を加えるつもりです。

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