タグ: Excel2016

Excelで情報共有しており、Excelに追記した内容をメールで共有するケースがあるかと思います。

面倒なメール作成を自動でできるようにしてみました。
件名やメール本文は微調整してご利用ください。

AutoCreateEmail

1 file(s) 25.16 KB

エクセルファイルをダウンロード

このエクセルファイルの作り方

①マクロを使えるようにする
「マクロを使えるようにする」を参照

②ボタンを配置する
　※ ボタンの配置方法は「表を複数の条件で絞り込む②」を参照

③ボタン配置時の以下の画面で「マクロ名」を「CreateEmail」として「新規作成」を押す

④ 「Microsoft Visual Basic for Applications」にて以下のコードを記載

Sub CreateEmail()
Dim oApp       As Object
Dim objMAIL    As Object
Dim messageList(1) As String
Dim n          As Long
Dim fullName As String
Dim firstName As String

On Error Resume Next
Set oApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If oApp Is Nothing Then
Set oApp = CreateObject("Outlook.Application")
oApp.GetNamespace("MAPI").GetDefaultFolder(6).display
End If

fullName = Application.UserName
firstName = Mid(fullName, 1, InStr(fullName, " ") - 1)

Set objMAIL = oApp.CreateItem(0)
'メールに載せるメッセージ本文'
messageList(0) = "お疲れ様です。" & firstName & "です。" & vbCrLf & vbCrLf & _
"共有ファイルNo." & Cells(3, 3).Value & "に追記を行いました。" & vbCrLf & _
"タイミングを見てご確認ください。" & vbCrLf & vbCrLf & _
"<\ShareServer\メールを自動作成する.xlsm>" & vbCrLf

messageList(1) = vbCrLf & "     以上、宜しくお願い致します。"

Dim adress As String
Dim i As Long
For i = 1 To 50

adress = adress + ThisWorkbook.Worksheets("宛先").Cells(i + 1, 2).Value
adress = adress + " ;"

Next i

objMAIL.To = adress
'件名'
objMAIL.Subject = "共有ファイルNo." & Cells(3, 3).Value & "を追加しました"
objMAIL.BodyFormat = 2 'HTML形式
objMAIL.Body = messageList(0) & messageList(1)
objMAIL.display

n = Len(messageList(0))
ActiveSheet.Range(Cells(Cells(3, 3) + 5, 2), Cells(Cells(3, 3) + 5, 5)).Copy
oApp.ActiveInspector.WordEditor.Range(n, n).Paste
Application.CutCopyMode = False

Set objMAIL = Nothing
Set oApp = Nothing
End Sub

売上データなど、Excelで作った表を送る場合に、メールやチャットにてテキスト形式で送りたいことがあると思います。
そんなExcel表からテキストへ変換するためのプログラムを作成してみました。

私はシステムエンジニアなので、プログラムのコメントでテキスト形式の表を書いたりします。

今回は、範囲選択した中のデータをテキスト形式の表にし、クリップボードにコピーします。(メモ帳等に張り付けてご利用ください)
なお、セルの書式設定が通貨(#,##0)の場合のみ三桁カンマを付与し、値が数値の場合は右寄せ、それ以外は左寄せで表を作成します。

ConvertExcelTableText

1 file(s) 22.45 KB

エクセルファイルをダウンロード

このエクセルファイルの作り方

①マクロを使えるようにする
「マクロを使えるようにする」を参照

②ボタンを配置する
　※ ボタンの配置方法は「表を複数の条件で絞り込む②」を参照

③ボタン配置時の以下の画面で「マクロ名」を「ConvertTable 」として「新規作成」を押す

④ 「Microsoft Visual Basic for Applications」にて以下のコードを記載

Sub ConvertTable()
    Dim result As String
    Dim startRow, startCol, endRow, endCol As Integer
    Dim selectArea As Range
    Set selectArea = Selection
    
    startRow = selectArea.Cells(1).Row
    startCol = selectArea.Cells(1).Column
    endRow = selectArea.Cells(selectArea.Count).Row
    endCol = selectArea.Cells(selectArea.Count).Column
    
    Dim widthDic As Object
    Set widthDic = CreateObject("Scripting.Dictionary")
    
    Dim maxWidth As Integer: maxWidth = 0
    
    Dim cellVal As String
    Dim margin As Integer
    
    
    ' 各列毎の最大幅を配列で保持
    For j = startCol To endCol Step 1
        For i = startRow To endRow Step 1
            cellVal = Cells(i, j).Value
            If IsNumeric(cellVal) And Cells(i, j).NumberFormatLocal = "#,##0" Then
                cellVal = Format(cellVal, "#,#")
            End If
            
            If maxWidth < LenB(StrConv(cellVal, vbFromUnicode)) Then
                maxWidth = LenB(StrConv(cellVal, vbFromUnicode))
            End If
        Next
        widthDic.Add j, maxWidth
        maxWidth = 0
    Next
    
    ' 表文字列の作成
    For i = startRow To endRow Step 1
        ' 線だけの行を書き込み
        For j = startCol To endCol Step 1
            If i = startRow Then
                If j = startCol Then
                    result = result &amp; "┌"
                Else
                    result = result &amp; "┬"
                End If
            Else
                If j = startCol Then
                    result = result &amp; "├"
                Else
                    result = result &amp; "┼"
                End If
            End If
            
            result = result &amp; String(Application.WorksheetFunction.RoundUp(widthDic.Item(j) / 2, 0), "─")
            
            If i = startRow And j = endCol Then
                result = result &amp; "┐"
            ElseIf i <> startRow And j = endCol Then
                result = result &amp; "┤"
            End If
        Next
        result = result &amp; vbCrLf
        ' 値の行を書き込み
        For j = startCol To endCol Step 1
            result = result &amp; "│"
            cellVal = Cells(i, j).Value
            If IsNumeric(cellVal) And Cells(i, j).NumberFormatLocal = "#,##0" Then
                cellVal = Format(cellVal, "#,#")
            End If
            
            margin = widthDic.Item(j) - LenB(StrConv(cellVal, vbFromUnicode))
            margin = margin + widthDic.Item(j) Mod 2
            
            If IsNumeric(cellVal) Then
                result = result &amp; Space(margin)
                result = result &amp; cellVal
            Else
                result = result &amp; cellVal
                result = result &amp; Space(margin)
            End If
            
            If j = endCol Then
                result = result &amp; "│"
            End If
        Next
        result = result &amp; vbCrLf
    Next
    
    ' 最下部の線を書き込み
    For j = startCol To endCol Step 1
        If j = startCol Then
            result = result &amp; "└"
        Else
            result = result &amp; "┴"
        End If
        
        result = result &amp; String(Application.WorksheetFunction.RoundUp(widthDic.Item(j) / 2, 0), "─")

        If j = endCol Then
            result = result &amp; "┘"
        End If
    Next
    
    '表文字列をクリップボードに格納する
    With New MSForms.DataObject
        .SetText result
        .PutInClipboard
    End With
End Sub

⑤ 「C:\Windows\System32\FM20.DLL」を参照する
※クリップボードに値を格納するためのアセンブリ
※ない場合は 「C:\Windows\SysWOW64\FM20.DLL」