今回説明するのは、バラバラに作成してあるデータを統一されたデータベースに自動変換するプログラムです。具体的には、エクセルのワークシートにあるデータ(名前、住所、電話番号、メールアドレス)を整理し、別のワークシートに適切な列に整形して転記するプロセスを実行します。このコードは、データの最終行と最終列を検索し、ループを使用して各セルのデータをチェックし、適切な列(名前、住所、電話番号、メールアドレス)にデータを転記します。最後に、転記した別のワークシートの列幅を自動調整します。
【データベースの必要性として】
情報を効率的に管理・検索・利用するために不可欠です。データベース化して使用することで、大量の情報を簡単に整理・保存し、迅速にアクセスできます。また、データの整合性や一貫性が保たれることで、エラーや重複の削減にもつながります。
【データを統一するメリット】
まず、データの整理が容易になり、分析やレポート作成が効率化されます。さらに、統一されたデータを用いることで、異なる部門やチーム間での情報共有がスムーズになり、他部署とのコラボレーションが向上します。また、データ品質が向上することで、ビジネス上の意思決定や戦略立案において、より正確かつ信頼性の高いデータに基づいた判断が可能になります。データ統一は、組織全体の業務効率と競争力の向上に寄与する重要な要素です。
●【EXCEL VBA エクセルデータの標準化・データの統一・データの整理については、下記を参照して下さい】
下記のサンプルプログラムは、ワークシートに存在するデータから名前、住所、電話番号、メールアドレスを抽出し、別のワークシートにデータベースの形式で整理・保存する処理を行うサンプルプログラムです。バラバラなデータを統一データとして整理する時に便利だと思います。
下記のサンプルプログラムを利用する事で日常業務にて下記の業務に有効利用できると思われます。
【プログラムの流れ】
【プログラム実行条件・注意事項】
★【サンプルプログラム】
下記のリンク先よりサンプルプログラムをダウンロードする事ができます。
● Create_database01(サンプルプログラム)
' ' Option Explicit Sub CreateDatabase() ' 変数の宣言 Dim wsSource As Worksheet Dim wsDest As Worksheet Dim lastRow, lastCol, destRow, I, J As Long ' ワークシートの設定 Set wsSource = ThisWorkbook.Sheets("SouceData") ' データがあるワークシートの名前を指定してください Set wsDest = ThisWorkbook.Sheets("DataBase") ' 列ヘッダーの設定 wsDest.Range("A1:D1").Value = Array("名前", "住所", "電話番号", "メールアドレス") ' 最終行と最終列を取得 lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column ' データの転記 destRow = 2 ' 列ヘッダーの下から開始 For I = 1 To lastRow For J = 1 To lastCol Dim nameStr As String Dim addrStr As String Dim telStr As String Dim emailStr As String ' 名前の登録 nameStr = wsSource.Cells(I, J).Value If InStr(nameStr, "@") = 0 And InStr(nameStr, "-") = 0 And _ InStr(nameStr, "都") = 0 And InStr(nameStr, "道") = 0 And _ InStr(nameStr, "府") = 0 And InStr(nameStr, "県") = 0 And _ InStr(nameStr, " ") = 0 Then ' 全角スペースも除外 wsDest.Cells(destRow, 1).Value = Trim(nameStr) End If ' 住所の登録 addrStr = wsSource.Cells(I, J).Value If (InStr(addrStr, "都") > 0 Or InStr(addrStr, "道") > 0 Or _ InStr(addrStr, "府") > 0 Or InStr(addrStr, "県") > 0) Then ' 全角スペースも徐外 wsDest.Cells(destRow, 2).Value = Trim(addrStr) End If ' 電話番号の登録 telStr = wsSource.Cells(I, J).Value If InStr(telStr, "-") > 0 And InStr(telStr, "-") < 6 Then wsDest.Cells(destRow, 3).Value = telStr End If ' メールアドレスの登録 emailStr = wsSource.Cells(I, J).Value If InStr(emailStr, "@") > 0 And InStr(emailStr, ".") > InStr(emailStr, "@") Then wsDest.Cells(destRow, 4).Value = emailStr End If Next J ' 次の行に移動 destRow = destRow + 1 Next I ' 自動調整 With wsDest .Activate .Columns.AutoFit End With End Sub ' '
下記のサンプルプログラムは、サンプルプログラム①の一部応用したものになります。3つのワークシートを使って、ソースデータから名前、住所(都道府県名・区市町村名)、電話番号、メールアドレスを判断して、それぞれのデータを整理し、データベース化「DataBase」ワークシートに転記する処理を行っています。新たに判断条件を登録してある「judgement」ワークシートを作成して、この内容に応じてデータベースを整理するように内容を追記しました。これにより、データベースの整理する条件内容の変更があってもワークシート「judgement」の内容を書き換えるだけで、簡単に変更する事ができます。
【データベースを整理する】
ワークシート「judgement」の説明について
①「名前」A列の検索条件として「@、ー、都、道、府、県、区、市、町、村」以外の文字列が名前と判断する。
②「住所(都道府県)」B列の検索条件として「都、道、府、県」が文字列に含まれるもの。
③「住所(区市町村)」C列の検索条件として「区、市、町、村」が文字列に含まれるもの。
④「電話番号」D列の検索条件として「ー」が文字列にふくまれるもの。
⑤「メールアドレス」E列の検索条件として「@」が文字列にふくまれるもの。
※注意点1として、A列の名前は指定文字がふくまれないものが名前と判断する。
※注意点2として、B列からE列については、指定文字が含まているが該当の項目とする。
※注意点3として、指定文字の文字列が複数の列に登録されていると判断に誤りが発生するので注意が必要
【プログラムの流れ】
① ワークシートを設定
② 列ヘッダーを設定
③ ソースデータの最終行と最終列を取得
④ データを転記(ワークシート「judgement」を元に判定)
⑤- a. 名前の登録
⑤- b. 都道府県名の登録
⑤ー c.区市町村名の登録
⑤- d. 電話番号の登録
⑤- e. メールアドレスの登録
⑥ 列幅の自動調整
【プログラム実行条件・注意事項】
1.ソースデータのワークシート名と判断条件のワークシート名が正しく設定されていることを確認してください。
2.判断条件が正確であることを確認してください。不正確な判断条件があると、正しくデータが転記されません。
3.コードはデータの形式に依存しているため、データ形式が変更されると、コードを修正する必要があります。
★【サンプルプログラム】
下記のリンク先よりサンプルプログラムをダウンロードする事ができます。
● Create_database02(サンプルプログラム)
' ' Option Explicit Sub CreateDatabase02() ' 変数の宣言 Dim wsSource As Worksheet Dim wsDest As Worksheet Dim wsJudgement As Worksheet Dim lastRow, lastCol, destRow, I, J, K As Long Dim judgementLastRow As Long ' ワークシートの設定 Set wsSource = ThisWorkbook.Sheets("SouceData") ' データがあるワークシート Set wsDest = ThisWorkbook.Sheets("DataBase") 'データベースを作成するワークシート Set wsJudgement = ThisWorkbook.Sheets("judgement") ' 判別条件があるワークシート ' 列ヘッダーの設定 wsDest.Range("A1:D1").Value = Array("名前", "都道府県", "区市町村", "電話番号", "メールアドレス") ' 最終行と最終列を取得 lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row 'データが登録しているワークシートのA列の最終行を取得 lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column ''データが登録しているワークシートのA列の最終行を取得 ' データの転記 destRow = 2 ' 列ヘッダーの下から開始 For I = 1 To lastRow For J = 1 To lastCol Dim nameStr As String Dim addrStr As String Dim telStr As String Dim emailStr As String Dim isName, isAddr, isTel, isEmail As Boolean ' 名前の登録 nameStr = wsSource.Cells(I, J).Value isName = False ' 名前判断条件を参照 judgementLastRow = wsJudgement.Cells(wsJudgement.Rows.Count, "A").End(xlUp).Row For K = 2 To judgementLastRow If InStr(nameStr, wsJudgement.Cells(K, 1).Value) = 0 Then '氏名を検索します isName = True '氏名あり Else isName = False '氏名なし Exit For End If Next K If isName Then '氏名が見つかればA列に登録 wsDest.Cells(destRow, "A").Value = Trim(nameStr) End If '都道府県の登録 addrStr = wsSource.Cells(I, J).Value isAddr = False ' 都道府県判断条件を参照 judgementLastRow = wsJudgement.Cells(wsJudgement.Rows.Count, "B").End(xlUp).Row For K = 2 To judgementLastRow If InStr(addrStr, wsJudgement.Cells(K, 2).Value) > 0 Then '都道府県名を検索します。 isAddr = True Exit For End If Next K If isAddr Then '都道府県名が見つかればB列に登録 wsDest.Cells(destRow, "B").Value = Trim(addrStr) End If ' 区市町村の登録 addrStr = wsSource.Cells(I, J).Value isAddr = False ' 区市町村判断条件を参照 judgementLastRow = wsJudgement.Cells(wsJudgement.Rows.Count, "C").End(xlUp).Row For K = 2 To judgementLastRow If InStr(addrStr, wsJudgement.Cells(K, "C").Value) > 0 Then '区市町村名を検索します。 isAddr = True Exit For End If Next K If isAddr Then '区市町村が見つかればC列に登録 wsDest.Cells(destRow, "C").Value = Trim(addrStr) End If ' 電話番号の登録 telStr = wsSource.Cells(I, J).Value isTel = False ' 電話番号判断条件を参照 judgementLastRow = wsJudgement.Cells(wsJudgement.Rows.Count, "D").End(xlUp).Row For K = 2 To judgementLastRow If InStr(telStr, wsJudgement.Cells(K, "D").Value) > 0 Then '電話番号を検索します。 isTel = True Exit For End If Next K If isTel Then '電話番号が見つかればD列に登録 wsDest.Cells(destRow, "D").Value = telStr End If ' メールアドレスの登録 emailStr = wsSource.Cells(I, J).Value isEmail = False ' メールアドレス判断条件を参照 judgementLastRow = wsJudgement.Cells(wsJudgement.Rows.Count, "E").End(xlUp).Row For K = 2 To judgementLastRow If InStr(emailStr, wsJudgement.Cells(K, "E").Value) > 0 Then 'メールアドレスを検索します。 isEmail = True Exit For End If Next K If isEmail Then 'メールアドレスが見つかればE列に登録 wsDest.Cells(destRow, "E").Value = emailStr End If Next J ' 次の行に移動 destRow = destRow + 1 Next I ' 自動調整 wsDest.Columns.AutoFit ' データベースシートをアクティブにする。 wsDest.Activate End Sub ' '