VBA – リボン日記

日報データを週報データに変えるSUM関数をイミディエイトに書き出す

Excel で日報データを週報に変えて、長期間のグラフを見やすくしようとした。SUM()関数を使って日報のデータを週報に集計すればいいのだが、手入力で範囲指定するとミスが出るのでVBAで書き出した。

ただし、なぜかVBA でタブが扱えなかったので、区切りが半角スペースになっている。これをテキストエディタの検索置換でタブに変えて、Excel のセルに貼れば、狙った通りの週報に変わる。

条件

セルはB2 とC2から下方向に日報データが並んでいるものとする。

コード

Option Explicit

'// 日報データを週報データに変えるSUM関数をイミディエイトに書き出す
Sub OutWeek()
  '//初期化
  Dim sumNum(5) As String
  Dim cellNum(1) As Long
  Dim ij As Long
  '//=SUM(B2:B8) =SUM(C2:C8)
  '//のように、B列、C列の2行目から日報データを集計する関数を書き出す
  sumNum(1) = "=SUM(B"
  sumNum(2) = ":B"
  sumNum(3) = ")    =SUM(C" '//BとCの間をタブ区切りにしてエクセルのセルに直接貼れるようにしたいが、タブがなぜか半角スペースに変換される
  sumNum(4) = ":C"
  sumNum(5) = ")"
  '//1週間の始まりと終わりの行
  cellNum(0) = 2
  cellNum(1) = 8
  '//53週(371日)分書き出す
  For ij = 1 To 53
    '//文字列と行数を結合してイミディエイトに書き出す
    'Str() で数字を文字列に変換、整数にすると文頭に半角スペースが入るので、CutLeft() で切り取り
    Debug.Print sumNum(1) + CutLeft(Str(cellNum(0)), 1) + sumNum(2) + CutLeft(Str(cellNum(1)), 1) + sumNum(3) + CutLeft(Str(cellNum(0)), 1) + sumNum(4) + CutLeft(Str(cellNum(1)), 1) + sumNum(5)
    '//7日後の行を指定
    cellNum(0) = cellNum(0) + 7
    cellNum(1) = cellNum(1) + 7
  Next ij
End Sub
'// 引数１：文字列
'// 引数２：削除文字数
'// 戻り値：削除後の文字列
Function CutLeft(s, i As Long) As String
    Dim iLen    As Long     '// 文字列長
    
    '// 文字列ではない場合
    If VarType(s) <> vbString Then
        Exit Function
    End If
    
    iLen = Len(s)
    
    '// 文字列長より指定文字数が大きい場合
    If iLen < i Then
        Exit Function
    End If
    
    '// 指定文字数を削除して返す
    CutLeft = Right(s, iLen - i)
End Function

Option Explicit

'// 日報データを週報データに変えるSUM関数をイミディエイトに書き出す

Sub OutWeek()

'//初期化

Dim sumNum(5) As String

Dim cellNum(1) As Long

Dim ij As Long

'//=SUM(B2:B8) =SUM(C2:C8)

'//のように、B列、C列の2行目から日報データを集計する関数を書き出す

sumNum(1) = "=SUM(B"

sumNum(2) = ":B"

sumNum(3) = ") =SUM(C" '//BとCの間をタブ区切りにしてエクセルのセルに直接貼れるようにしたいが、タブがなぜか半角スペースに変換される

sumNum(4) = ":C"

sumNum(5) = ")"

'//1週間の始まりと終わりの行

cellNum(0) = 2

cellNum(1) = 8

'//53週(371日)分書き出す

For ij = 1 To 53

'//文字列と行数を結合してイミディエイトに書き出す

'Str() で数字を文字列に変換、整数にすると文頭に半角スペースが入るので、CutLeft() で切り取り

Debug.Print sumNum(1) + CutLeft(Str(cellNum(0)), 1) + sumNum(2) + CutLeft(Str(cellNum(1)), 1) + sumNum(3) + CutLeft(Str(cellNum(0)), 1) + sumNum(4) + CutLeft(Str(cellNum(1)), 1) + sumNum(5)

'//7日後の行を指定

cellNum(0) = cellNum(0) + 7

cellNum(1) = cellNum(1) + 7

Next ij

End Sub

'// 引数１：文字列

'// 引数２：削除文字数

'// 戻り値：削除後の文字列

Function CutLeft(s, i As Long) As String

Dim iLen As Long '// 文字列長

'// 文字列ではない場合

If VarType(s) <> vbString Then

Exit Function

End If

iLen = Len(s)

'// 文字列長より指定文字数が大きい場合

If iLen < i Then

Exit Function

End If

'// 指定文字数を削除して返す

CutLeft = Right(s, iLen - i)

End Function

文字の切り取りは、この記事のものを使わせてもらった。
VBAで文字列の右側や左側から指定文字数削除する

Outlook のメールを読んで、指定した情報をVBAを使って抜き出す

データベースを使わない、または外部のウェブサービスからのメールを受信していて、そのメールの中から住所を抜き出し、顧客分布を測定したい時がある。Excel とOutlook ならVBA が使えるので、それを一部自動化した。

この解説は、限られた条件で使ったものなので、サンプルプログラムとして記録を残す。

前提

Oltlook の受信トレイに「予約」フォルダ、その直下に「A店」と「B店」のフォルダがある

受信トレイ
└予約
├A店
└B店

それぞれのフォルダはOutlook のルールで、件名ごとにフォルダ分けされるようになっている

「A店」と「B店」に保存されたメールの中に、「住所」情報がある

実装したい機能

指定したフォルダを次々に読み込んで、住所を抜き出し、都道府県、市町村、区、その他で横方向のセルに挿入する

セルは横方向が属性、縦方向がメールごとの内容にして、データを表に入力する

VBA スクリプト

'Outlook の指定フォルダから､一気にメール内容の住所を取得して､都道府県､市､区､で分ける
'「住所」の次の行を調べているだけなので、メールがメールフォームを使わずに返信してきた場合は住所が決まった位置に書かれていないため抜ける

'全てのプロシージャで使用できる変数宣言
Dim subFolder As String ' サブフォルダ名
Dim folderArray() As String ' 選択するフォルダ名
Dim nextRow As Long '挿入するセルの開始行

Sub GetCustomersAddress()

    '初期設定
    'フォルダ構造は次のようになっている
    '受信トレイOutlook 2013
    '└予約
    '　├A店
    '　├B店
    '　└C店
    ReDim folderArray(2)
    subFolder = "予約"
    folderArray(1) = "A店"
    folderArray(2) = "B店"

    nextRow = 2

    '指定したフォルダ内にGetMail()の処理を実施する
    Call GetMail(subFolder, folderArray(1), nextRow)
    Call GetMail(subFolder, folderArray(2), nextRow)

End Sub

'Outlook にある指定されたフォルダを順に読み込み、「住所」が書かれた行の次の行にある住所を、都道府県、市区町村、以下で分けてセルに記載する
Function GetMail(ByVal nowFolder As String, ByVal ssFolder As String, ByVal nowRow As Long)
    Dim objOutlook As Outlook.Application
    Dim myNamespace As Outlook.Namespace
    Dim myInbox, mySubfolder

    Set objOutlook = New Outlook.Application ' Outlook アプリケーションオブジェクトの取得
    Set myNamespace = objOutlook.GetNamespace("MAPI") ' Outlook のメールフォルダにアクセスするためのNamespace オブジェクトを取得
    
    ' GetDefaultFolder() の引数olFolderInbox は、受信トレイフォルダー(メール)を指す
    Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox) ' 受信トレイのフォルダオブジェクトを取得
    Set mySubfolder = myInbox.Folders(nowFolder).Folders(ssFolder) ' 引数で指定された階層のサブフォルダオブジェクトを取得


    Dim i As Long
    Dim ij As Integer
    Dim textSolo As String
    Dim stringLine As String
    Dim sPrefecture As String
    Dim sCity As String
    Dim sKu As String

    ' 取得したサブフォルダmySubfolder のアイテム数をすべて読む
    For i = 1 To mySubfolder.Items.Count
      'シート"email"を指定
      With ThisWorkbook.Worksheets("email")
        arrayLine = Split(mySubfolder.Items(i).Body, vbCrLf) 'メール本文を改行で分割
        '住所を書き出す
        For ij = LBound(arrayLine) To UBound(arrayLine)
            stringLine = arrayLine(ij)
            ' 行が指定のキーワード「住所」なのか確認
            If stringLine Like "*住所*" Then
                textSolo = arrayLine(ij + 1)
                '都道府県
                If (InStr(textSolo, "道") <> 0) Or (InStr(textSolo, "東京都") <> 0) Or (InStr(textSolo, "府") <> 0) Then
                    sPrefecture = Mid(textSolo, 1, 3) ' 都道府県を取得
                    textSolo = Right(textSolo, Len(textSolo) - 3) ' testSolo から都道府県を削除
                ElseIf (InStr(textSolo, "県") <> 0) Then
                    sPrefecture = Mid(textSolo, 1, InStr(textSolo, "県"))
                    textSolo = Right(textSolo, Len(textSolo) - InStr(textSolo, "県"))
                ElseIf (InStr(textSolo, "名古屋市") <> 0) Then
                    '名古屋市から書き始める人用
                    sPrefecture = "愛知県"
                End If
                .Cells(i + nowRow, 2).Value = sPrefecture ' 都道府県を指定されたセルに記載
                
                '市
                If (InStr(textSolo, "市") <> 0) Then
                    sCity = Mid(textSolo, 1, InStr(textSolo, "市")) ' 市を取得
                    textSolo = Right(textSolo, Len(textSolo) - InStr(textSolo, "市")) ' textSolo から市までを削除
                ElseIf (InStr(textSolo, "郡") <> 0) Then
                    sCity = Mid(textSolo, 1, InStr(textSolo, "郡"))
                    textSolo = Right(textSolo, Len(textSolo) - InStr(textSolo, "郡"))
                Else
                    sCity = ""
                End If
                .Cells(i + nowRow, 3).Value = sCity ' 市を指定されたセルに記載
                '区
                If (InStr(textSolo, "区") <> 0) Then
                    sKu = Mid(textSolo, 1, InStr(textSolo, "区")) ' 句を取得
                    textSolo = Right(textSolo, Len(textSolo) - InStr(textSolo, "区")) ' textSolo から区までを削除
                Else
                    sKu = ""
                End If
                .Cells(i + nowRow, 4).Value = sKu ' 区を指定されたセルに記載
                .Cells(i + nowRow, 5).Value = textSolo ' それ以外の住所を指定されたセルに記載
            End If
        Next
      End With
    Next i

    nextRow = nowRow + mySubfolder.Items.Count
End Function

100

101

102

103

'Outlook の指定フォルダから､一気にメール内容の住所を取得して､都道府県､市､区､で分ける

'「住所」の次の行を調べているだけなので、メールがメールフォームを使わずに返信してきた場合は住所が決まった位置に書かれていないため抜ける

'全てのプロシージャで使用できる変数宣言

Dim subFolder As String ' サブフォルダ名

Dim folderArray() As String ' 選択するフォルダ名

Dim nextRow As Long '挿入するセルの開始行

Sub GetCustomersAddress()

'初期設定

'フォルダ構造は次のようになっている

'受信トレイOutlook 2013

'└予約

'　├A店

'　├B店

'　└C店

ReDim folderArray(2)

subFolder = "予約"

folderArray(1) = "A店"

folderArray(2) = "B店"

nextRow = 2

'指定したフォルダ内にGetMail()の処理を実施する

Call GetMail(subFolder, folderArray(1), nextRow)

Call GetMail(subFolder, folderArray(2), nextRow)

End Sub

'Outlook にある指定されたフォルダを順に読み込み、「住所」が書かれた行の次の行にある住所を、都道府県、市区町村、以下で分けてセルに記載する

Function GetMail(ByVal nowFolder As String, ByVal ssFolder As String, ByVal nowRow As Long)

Dim objOutlook As Outlook.Application

Dim myNamespace As Outlook.Namespace

Dim myInbox, mySubfolder

Set objOutlook = New Outlook.Application ' Outlook アプリケーションオブジェクトの取得

Set myNamespace = objOutlook.GetNamespace("MAPI") ' Outlook のメールフォルダにアクセスするためのNamespace オブジェクトを取得

' GetDefaultFolder() の引数olFolderInbox は、受信トレイフォルダー(メール)を指す

Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox) ' 受信トレイのフォルダオブジェクトを取得

Set mySubfolder = myInbox.Folders(nowFolder).Folders(ssFolder) ' 引数で指定された階層のサブフォルダオブジェクトを取得

Dim i As Long

Dim ij As Integer

Dim textSolo As String

Dim stringLine As String

Dim sPrefecture As String

Dim sCity As String

Dim sKu As String

' 取得したサブフォルダmySubfolder のアイテム数をすべて読む

For i = 1 To mySubfolder.Items.Count

'シート"email"を指定

With ThisWorkbook.Worksheets("email")

arrayLine = Split(mySubfolder.Items(i).Body, vbCrLf) 'メール本文を改行で分割

'住所を書き出す

For ij = LBound(arrayLine) To UBound(arrayLine)

stringLine = arrayLine(ij)

' 行が指定のキーワード「住所」なのか確認

If stringLine Like "*住所*" Then

textSolo = arrayLine(ij + 1)

'都道府県

If (InStr(textSolo, "道") <> 0) Or (InStr(textSolo, "東京都") <> 0) Or (InStr(textSolo, "府") <> 0) Then

sPrefecture = Mid(textSolo, 1, 3) ' 都道府県を取得

textSolo = Right(textSolo, Len(textSolo) - 3) ' testSolo から都道府県を削除

ElseIf (InStr(textSolo, "県") <> 0) Then

sPrefecture = Mid(textSolo, 1, InStr(textSolo, "県"))

textSolo = Right(textSolo, Len(textSolo) - InStr(textSolo, "県"))

ElseIf (InStr(textSolo, "名古屋市") <> 0) Then

'名古屋市から書き始める人用

sPrefecture = "愛知県"

End If

.Cells(i + nowRow, 2).Value = sPrefecture ' 都道府県を指定されたセルに記載

'市

If (InStr(textSolo, "市") <> 0) Then

sCity = Mid(textSolo, 1, InStr(textSolo, "市")) ' 市を取得

textSolo = Right(textSolo, Len(textSolo) - InStr(textSolo, "市")) ' textSolo から市までを削除

ElseIf (InStr(textSolo, "郡") <> 0) Then

sCity = Mid(textSolo, 1, InStr(textSolo, "郡"))

textSolo = Right(textSolo, Len(textSolo) - InStr(textSolo, "郡"))

Else

sCity = ""

End If

.Cells(i + nowRow, 3).Value = sCity ' 市を指定されたセルに記載

'区

If (InStr(textSolo, "区") <> 0) Then

sKu = Mid(textSolo, 1, InStr(textSolo, "区")) ' 句を取得

textSolo = Right(textSolo, Len(textSolo) - InStr(textSolo, "区")) ' textSolo から区までを削除

Else

sKu = ""

End If

.Cells(i + nowRow, 4).Value = sKu ' 区を指定されたセルに記載

.Cells(i + nowRow, 5).Value = textSolo ' それ以外の住所を指定されたセルに記載

End If

End With

Next i

nextRow = nowRow + mySubfolder.Items.Count

End Function

動作

スクリプトを実行すると、シート”email”に結果を書き出す

Excel の複数のシートで、セルの頭出しをしたい

データの整理で、Excel を使って、別のシートからのデータをコピペする作業がある。毎回決まった位置に目視で確認しながらマウス操作で選択していたが、この頭出しをVBA で実現した。

利用する言語

Visual Basic for Applications (VBA)

実装したい内容

決まったシートから順番に、指定したセルの位置を選択状態にしたい

スクリプト

Option Explicit
' スリープを使う
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'初期設定
Dim ij As Integer

'セル頭出し関数実行
Sub F1st()
    Call FocusCell("C86")
End Sub
Sub F2nd()
    Call FocusCell("C117")
End Sub
Sub F3rd()
    Call FocusCell("C146")
End Sub
' セル頭出し、シートを順番に選択して、指定されたセルを選択状態にする
Function FocusCell(ByVal tCell As String)
    For ij = 4 To Sheets.Count
        Sheets(Sheets(ij).Name).Select
        Sleep 50
        Range(tCell).Activate
        Sleep 50
    Next
    ' 先頭のセルを再び選択
    Sheets(Sheets(4).Name).Select
End Function

Option Explicit

' スリープを使う

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'初期設定

Dim ij As Integer

'セル頭出し関数実行

Sub F1st()

Call FocusCell("C86")

End Sub

Sub F2nd()

Call FocusCell("C117")

End Sub

Sub F3rd()

Call FocusCell("C146")

End Sub

' セル頭出し、シートを順番に選択して、指定されたセルを選択状態にする

Function FocusCell(ByVal tCell As String)

For ij = 4 To Sheets.Count

Sheets(Sheets(ij).Name).Select

Sleep 50

Range(tCell).Activate

Sleep 50

' 先頭のセルを再び選択

Sheets(Sheets(4).Name).Select

End Function

内容

セル頭出し関数F1st() などで、選択するセルの位置を指定
FocusCell() でシート4から順番にシートを選択して、指定されたセルを選択する