EXCEL VBA データベース作成・データ整理術: 無秩序な情報を自動で整理・転記する方法（テクニック）

2023年4月13日

EXCEL VBA データベース作成・データ整理術: 無秩序な情報を自動で整理・転記する方法（テクニック）

●はじめに

今回説明するのは、バラバラに作成してあるデータを統一されたデータベースに自動変換するプログラムです。具体的には、エクセルのワークシートにあるデータ（名前、住所、電話番号、メールアドレス）を整理し、別のワークシートに適切な列に整形して転記するプロセスを実行します。このコードは、データの最終行と最終列を検索し、ループを使用して各セルのデータをチェックし、適切な列（名前、住所、電話番号、メールアドレス）にデータを転記します。最後に、転記した別のワークシートの列幅を自動調整します。

【データベースの必要性として】
情報を効率的に管理・検索・利用するために不可欠です。データベース化して使用することで、大量の情報を簡単に整理・保存し、迅速にアクセスできます。また、データの整合性や一貫性が保たれることで、エラーや重複の削減にもつながります。

【データを統一するメリット】
まず、データの整理が容易になり、分析やレポート作成が効率化されます。さらに、統一されたデータを用いることで、異なる部門やチーム間での情報共有がスムーズになり、他部署とのコラボレーションが向上します。また、データ品質が向上することで、ビジネス上の意思決定や戦略立案において、より正確かつ信頼性の高いデータに基づいた判断が可能になります。データ統一は、組織全体の業務効率と競争力の向上に寄与する重要な要素です。

●【EXCEL VBA エクセルデータの標準化・データの統一・データの整理については、下記を参照して下さい】

EXCEL VBA エクセルデータの標準化・データの統一・データの整備（テクニック）

●プログラム説明（サンプル①）

下記のサンプルプログラムは、ワークシートに存在するデータから名前、住所、電話番号、メールアドレスを抽出し、別のワークシートにデータベースの形式で整理・保存する処理を行うサンプルプログラムです。バラバラなデータを統一データとして整理する時に便利だと思います。

下記のサンプルプログラムを利用する事で日常業務にて下記の業務に有効利用できると思われます。

顧客情報の整理・管理
社内連絡先のデータベース作成
会員情報の一覧表作成

【プログラムの流れ】

wsSourceとwsDestワークシートの設定
wsDestワークシートの列ヘッダー設定
ソースワークシートの最終行と最終列の取得
データの転記 a. 名前の登録 b. 住所の登録 c. 電話番号の登録 d. メールアドレスの登録
保存先ワークシートの列幅自動調整

【プログラム実行条件・注意事項】

ソースデータのワークシート名を正確に指定する必要があります。
データが正確に分類されるためには、データの形式が一貫していることが前提です。
一部のデータが分類できない場合や誤分類される可能性があります。データの整合性を確認することが重要です。

★【サンプルプログラム】
下記のリンク先よりサンプルプログラムをダウンロードする事ができます。
●　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
'
'

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

●実行前～実行後　※「SouceData」ワークシートに散らばっていた名前、住所、電話番号、メールアドレスのデータが、「DataBase」ワークシートに整理され、項目別に移動しました。これで、オフィス業務に使えるデータベースができました。

EXCEL VBA データベース作成・データ整理術: 無秩序な情報を自動で整理・（判断条件を指定して整理）

●プログラム説明（サンプル②）

下記のサンプルプログラムは、サンプルプログラム①の一部応用したものになります。3つのワークシートを使って、ソースデータから名前、住所(都道府県名・区市町村名)、電話番号、メールアドレスを判断して、それぞれのデータを整理し、データベース化「DataBase」ワークシートに転記する処理を行っています。新たに判断条件を登録してある「judgement」ワークシートを作成して、この内容に応じてデータベースを整理するように内容を追記しました。これにより、データベースの整理する条件内容の変更があってもワークシート「judgement」の内容を書き換えるだけで、簡単に変更する事ができます。

【データベースを整理する】
ワークシート「judgement」の説明について
①「名前」A列の検索条件として「＠、ー、都、道、府、県、区、市、町、村」以外の文字列が名前と判断する。
②「住所（都道府県）」B列の検索条件として「都、道、府、県」が文字列に含まれるもの。
③「住所（区市町村）」C列の検索条件として「区、市、町、村」が文字列に含まれるもの。
④「電話番号」D列の検索条件として「ー」が文字列にふくまれるもの。
⑤「メールアドレス」E列の検索条件として「＠」が文字列にふくまれるもの。

※注意点１として、A列の名前は指定文字がふくまれないものが名前と判断する。
※注意点２として、Ｂ列からＥ列については、指定文字が含まているが該当の項目とする。
※注意点３として、指定文字の文字列が複数の列に登録されていると判断に誤りが発生するので注意が必要

【プログラムの流れ】
①　ワークシートを設定
②　列ヘッダーを設定
③　ソースデータの最終行と最終列を取得
④　データを転記（ワークシート「judgement」を元に判定）
⑤－　a. 名前の登録
⑤－　b. 都道府県名の登録
⑤ー　c.区市町村名の登録
⑤－　ｄ. 電話番号の登録
⑤－　e. メールアドレスの登録
⑥　列幅の自動調整

【プログラム実行条件・注意事項】

１．ソースデータのワークシート名と判断条件のワークシート名が正しく設定されていることを確認してください。
２．判断条件が正確であることを確認してください。不正確な判断条件があると、正しくデータが転記されません。
３．コードはデータの形式に依存しているため、データ形式が変更されると、コードを修正する必要があります。

★【サンプルプログラム】
下記のリンク先よりサンプルプログラムをダウンロードする事ができます。
●　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
    '
    '

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

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

●実行前～実行後　※　プログラム実行後、「SouceData」ワークシート内のデータから名前、住所(都道府県、区市町村)、電話番号、メールアドレスが判断され、「DataBase」ワークシートにそれぞれのデータが整理されて転記されます。判断条件は「judgement」ワークシートに基づいています。最後に、「DataBase」ワークシートの列幅が自動調整されます。