デジタルの力で自分を超える
こんにちはHillaryです。
企業の組織風土改革のため、理念やビジョンの浸透活動に取り組む会社員です。
業務課題探しの旅
“自己開示で組織力向上”
組織風土改革の一端を担う部署で、自社のビジョンを伝える役割を果たしています。その役割を果たす中で、自分自身がどう向き合っているのかを改めて考えることがあります。これまでの私は、誰かに頼ることなく、自分一人で仕事を進めるタイプでした。スキルアップには興味があるけど、自分のことを他人に開示するのは苦手だったんです。でも、仕事の課題を見つけて解決するためには、チームのみんなと協力することが大切だと気づきました。自分だけの視点で考えていたら見えなかったことも、みんなの意見を聞くことで新たな視点が得られ、それが改善につながるんです。
“ノーコードで業務改革を”
プログラミングが難しくて敬遠していた私も、誰でも手軽にデジタルツールを作れる方法があることを知りました。その方法が、MakeやGlideなどのノーコードツールです。これらのツールを使えば、専門的な技術がなくても簡単にアプリケーションを作成できるんです。これまで難しく感じていたことも、すぐに使いこなせる手段があることに驚きました。私もこのGlideというノーコードツールを活用して、自分のアイデアを形にしました。それが、この業務進捗管理アプリです。
デジタルで身近なことから課題解決
“試行錯誤の業務改善”
しかし・・・・。チームメンバーには不評でした。Glideに興味をそそられ、業務改善につながるアプリを!!という事で制作していましたが、そもそも、業務進捗管理をアプリで共有することを、チームメンバーはだれも望んでいませんでした。
何度も行った業務課題ミーティングでデジタルで解決できるポイントを見つけられず、視点を変えてメンバーの業務を理解することに専念しました。数回のミーティングを経て、各社への督促通知を自動化できれば助かるという提案があり、早速、実現できるよう取り組みました。
”VBAマクロでメール一括作成”
デジタルツールを決める際、メールの宛先や内容は、Excelシートから転記するため、ノーコードツールではなく、VBAマクロを使用することにしました。VBAコードは、ChatGPTがものすごいスピードで書いてくれます。検証と修正を繰り返した結果、メール送信先シートから上から順にメール作成シートへ転記すること、Outlookメールを作成すること、この２つのVBAコードを実行することで、メールの一括作成に成功しました。
”一括メール作成で使用したVBAマクロコード”
メール送信先シートにある情報を、上から順にメール作成シートに転記するVBAマクロです。
Sub CreateEmailsAndSend()
Dim SourceSheet As Worksheet
Dim TargetSheet As Worksheet
Dim SourceRow As Long
' シートの設定
Set SourceSheet = ThisWorkbook.Sheets("メール送信先")
Set TargetSheet = ThisWorkbook.Sheets("メール作成")
' メール送信先シートの2行目から開始
For SourceRow = 2 To SourceSheet.Cells(SourceSheet.Rows.Count, "E").End(xlUp).Row
' 値を転記
TargetSheet.Cells(2, "C").Value = SourceSheet.Cells(SourceRow, "E").Value
TargetSheet.Cells(3, "C").Value = SourceSheet.Cells(SourceRow, "F").Value
TargetSheet.Cells(4, "C").Value = SourceSheet.Cells(SourceRow, "G").Value
TargetSheet.Cells(6, "C").Value = SourceSheet.Cells(SourceRow, "J").Value
TargetSheet.Cells(7, "C").Value = SourceSheet.Cells(SourceRow, "K").Value
TargetSheet.Cells(8, "C").Value = SourceSheet.Cells(SourceRow, "L").Value
TargetSheet.Cells(9, "C").Value = SourceSheet.Cells(SourceRow, "M").Value
TargetSheet.Cells(11, "C").Value = SourceSheet.Cells(SourceRow, "N").Value
TargetSheet.Cells(12, "C").Value = SourceSheet.Cells(SourceRow, "O").Value
TargetSheet.Cells(13, "C").Value = SourceSheet.Cells(SourceRow, "P").Value
TargetSheet.Cells(14, "C").Value = SourceSheet.Cells(SourceRow, "Q").Value
TargetSheet.Cells(15, "C").Value = SourceSheet.Cells(SourceRow, "R").Value
TargetSheet.Cells(16, "C").Value = SourceSheet.Cells(SourceRow, "H").Value
TargetSheet.Cells(17, "C").Value = SourceSheet.Cells(SourceRow, "S").Value
TargetSheet.Cells(18, "C").Value = SourceSheet.Cells(SourceRow, "T").Value
TargetSheet.Cells(19, "C").Value = SourceSheet.Cells(SourceRow, "U").Value
TargetSheet.Cells(20, "C").Value = SourceSheet.Cells(SourceRow, "W").Value
TargetSheet.Cells(21, "C").Value = SourceSheet.Cells(SourceRow, "X").Value
TargetSheet.Cells(22, "C").Value = SourceSheet.Cells(SourceRow, "Y").Value
' メール作成のマクロを実行
Call メール作成2
' マクロの次の実行を待つ
DoEvents
Next SourceRow
End Sub
Outlookメールを作成するVBAコードです。
Sub メール作成2()
' Outlookアプリケーションオブジェクトの取得
Dim MyOutlook As Object
Set MyOutlook = CreateObject("Outlook.Application")
' メールitemオブジェクトの取得
Dim Mailitem As Object
Set Mailitem = MyOutlook.CreateItem(0) ' 0 は olMailItem の定数
' 宛先やCcの設定
With Mailitem
If Range("C2").Value <> "" Then
.To = Range("C2").Value ' 宛先
End If
If Range("C3").Value <> "" Then
.CC = Range("C3").Value ' Cc
End If
If Range("C4").Value <> "" Then
.BCC = Range("C4").Value ' Bcc
End If
.Subject = Range("C6").Value ' 件名
' 本文の設定
Dim bodyRange As Range
Set bodyRange = Range("C7:C25")
.Body = Join(Application.Transpose(bodyRange.Value), vbCrLf)
End With
' メールの表示
Mailitem.Display
End Sub”VBAマクロってすごい”
チームメンバーの意見を伺ったところ「アンケート未報告の督促や研修申し込みの再通知にも使える」といった意見をいただき、活用の幅が広がりそうです。VBAマクロで自動化ができるなら、集計作業も作ってほしいなどの要望もいただき、早速作ってみました。
指定したフォルダの中にあるデータを、VBAの実行で一括にまとめます。シートのコピーはExcelの機能を活用し、必要なデータをVBAを実行で一覧表にとりこむ仕組みになっています。この仕組みによって、業務の合間を縫って
数日がかりで行っていた作業が、1分ほどで完了します。次回の実施アンケートではこちらを使って集計をする予定です。
”アンケート集計で使用したVBAマクロコード”
フォルダー内のExcelを一つにまとめるVBAです
Public Sub Sample()
Dim bkWork As Workbook '作業用ワークブック
Dim bkSrc As Workbook 'コピー元ワークブック
Dim shtIni As Worksheet '初期ワークシート
Dim folderPath As String '処理対象のフォルダパス
Dim tmpSinw As Long 'SheetsInNewWorkbook一次記憶用
Dim tmpDa As Boolean 'DisplayAlerts一次記憶用
Dim itm As Object
'Excelファイルが保存されているフォルダを選択
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False '複数選択しない
.Title = "Excelファイルが保存されているフォルダを選択"
If .Show = True Then
folderPath = .SelectedItems(1) '選択したフォルダのパスを変数に格納
Else
Exit Sub 'フォルダが選択されなかった場合は処理終了
End If
End With
'作業用ワークブックの作成
With Application
tmpSinw = .SheetsInNewWorkbook '新規ワークブックに自動的に挿入されるシート数を記憶
.SheetsInNewWorkbook = 1
Set bkWork = .Workbooks.Add 'ワークブック追加
Set shtIni = bkWork.Sheets(1) '最初の空白ワークシートを記憶
.SheetsInNewWorkbook = tmpSinw '新規ワークブックに自動的に挿入されるシート数を元に戻す
End With
'ファイルの処理にFileSystemObjectオブジェクトを利用
With CreateObject("Scripting.FileSystemObject")
'指定したフォルダ内のファイルを順番に処理
For Each itm In .GetFolder(folderPath).Files
'処理対象となるファイルの拡張子を指定
Select Case LCase(.GetExtensionName(itm.Path))
Case "xls", "xlsx", "xlsm", "csv"
Set bkSrc = Application.Workbooks.Open(itm.Path) 'コピー元のワークブックを開く
With bkWork
'全シートを作業用ワークブックにコピー
'※同名のワークシートがある場合は自動的にシート名が変更される
bkSrc.Sheets.Copy After:=.Sheets(.Sheets.Count)
End With
bkSrc.Close SaveChanges:=False 'コピー元のワークブックを変更せずに閉じる
End Select
Next
End With
'最初の空白ワークシートを削除
If bkWork.Sheets.Count > 1 Then
With Application
tmpDa = .DisplayAlerts '警告の表示状態を記憶
.DisplayAlerts = False '警告の表示を無効に設定
shtIni.Delete 'ワークシート削除
.DisplayAlerts = tmpDa '警告の表示状態を元に戻す
End With
End If
End Sub集計表から値を検索して転記するVBAコードです
Sub 転記と集計()
Dim 社別研修実績 As Worksheet
Dim シート As Worksheet
Dim 社別研修実績の行 As Range
Dim 検索対象値 As Variant
' 社別研修実績のシートを設定
Set 社別研修実績 = Worksheets("社別研修実績")
' 各シートの処理
For Each シート In ThisWorkbook.Sheets
If シート.Name <> "社別研修実績" Then ' 社別研修実績以外のシートの処理
' 社別研修実績を除く各シートのC列の13行目の値を取得
検索対象値 = シート.Cells(13, 3).Value
' 社別研修実績のC列から検索
Set 社別研修実績の行 = 社別研修実績.Columns(3).Find(What:=検索対象値, LookIn:=xlValues, LookAt:=xlWhole)
' 検索結果を確認
If Not 社別研修実績の行 Is Nothing Then
' 同じ行に転記
' E列に転記
社別研修実績.Cells(社別研修実績の行.Row, 5).Value = シート.Cells(13, 4).Value
' F列に転記
社別研修実績.Cells(社別研修実績の行.Row, 6).Value = シート.Cells(28, 4).Value
' G列に転記
社別研修実績.Cells(社別研修実績の行.Row, 7).Value = シート.Cells(28, 4).Value
' H列に転記
社別研修実績.Cells(社別研修実績の行.Row, 8).Value = シート.Cells(30, 4).Value
' I列に転記
社別研修実績.Cells(社別研修実績の行.Row, 9).Value = シート.Cells(31, 4).Value
' J列に転記（D列の32行目、33行目、34行目の和）
社別研修実績.Cells(社別研修実績の行.Row, 10).Value = _
シート.Cells(32, 4).Value + シート.Cells(33, 4).Value + シート.Cells(34, 4).Value
Else
' 検索が失敗した場合の処理
Debug.Print "検索失敗 - 行が見つかりませんでした。"
End If
End If
Next シート
End Sub
あとがき
デジタルで業務改革をする取り組みを気づいたことがります。デジタルツールの活用方法はネット上の様々な場所に掲載されています。しかも、その機軸を辿ると同じ事ができるように詳細が書かれています。初心者の私が解決方法を探すのに、これはとてもありがたい記録でした。ただ、誰かにとっては有効でも、無効な情報も山ほどあります。信頼性の高い情報源やコミュニティへの参加が重要です。様々な人との交流を通じて、最新で信頼性のある情報を取り入れることが、効果的なデジタル活用につながります。デジタルの世界でも、成功するには人とのつながりが鍵となることに気づきました。
これからも身近な課題をみつけ、デジタル技術の活用や新しいツールの導入に挑戦し、組織の生産性向上に寄与していきたいと思います。
お世話になった皆さまありがとうございました。