EXCEL VBA データの振り分け・データの抽出・別シートへ転記（テクニック）
EXCEL VBA データの振り分け・データの抽出・別シートへ転記（テクニック）
●はじめに
EXCELでデータを作成して、そのデータに対して条件によりデータを振り分ける事がありと思います。今回は、データの振り分け方法で会社で利用できそうなサンプルプログラムを３パターン作成いたしました。それでは順番に説明いたします。
EXCEL VBA 選択した都道府県名から該当する住所データを別シートに転記
●プログラム説明 （サンプル①）
下記のサンプルプログラムは、都道府県名を選択してシート「住所一覧」（住所録）から該当するデータ（住所録）を別シート「都道府県振分」に転記するプログラムです。ワークシート「都道府県名」のセル「C３」に都道府県名を指定してを実行する事で、該当データが別シートに転記します。
※実行ボタンにつきましては、https://akira55.com/button/ を参照してください。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
Sub Sort都道府県_抽出転記() Dim ws01, ws02 As Worksheet Dim I, M, lRow, mRow As Long Dim kensaku As String Set ws01 = Worksheets("住所一覧") Set ws02 = Worksheets("都道府県振分") mRow = ws02.Cells(Rows.Count, "A").End(xlUp).Row 'シート「都道府県名振分」の最終行を取得 ws02.Range("A7:D" & mRow + 1).Clear 'シート「都道府県名振分」にある前回の結果データをクリアー kensaku = ws02.Range("C3") '検索する都道府県名を「kensaku」へ代入 lRow = ws01.Cells(Rows.Count, "A").End(xlUp).Row mRow = 7 'シート「都道府県名振分」に転記する開始行の７行目を設定 For I = 2 To lRow If ws01.Cells(I, "D") Like "[" & kensaku & "]*" Then 'シート「住所一覧」から指定した都道府県名に該当する住所を検索する。 ws02.Range("A" & mRow & ":D" & mRow).Value = ws01.Range("A" & I & ":D" & I).Value '検索条件に該当する住所をシート「都道府県振分」に転記する mRow = mRow + 1 '転記する行に対して＋１加算する。 End If Next I ws02.Range("A7:D" & mRow - 1).Borders.LineStyle = xlContinuous 'シート「都道府県振分」に転記されたデータの最終行まで罫線を引く End Sub |
●実行前～実行後 ※プログラム実行後、指定した都道府県名に該当するデータが別シート「都道府県名振分」に転記されました。このプログラムにつきましては、何度も実行可能に作成しています。
EXCEL VBA 個人別の成績データからランク付けを自動振り分け（別シートに転記）
●プログラム説明 (サンプル②)
下記のサンプルプログラムは、シート「点数一覧」に個別ごとの点数一覧が表示されています。この点数（合計）に応じて個人ごとに点数のランク付けを行うサンプルプログラムです。ランク分けする表は、シート「点数ランク分け」に「ランク表」が作成しておりますので、この点数の範囲内で個人ごとにランク付けを行います。ランク表を作成する事で、点数範囲の変更があっても表を変更する事で、プログラムを修正することなく利用する事ができます。
※実行ボタンにつきましては、https://akira55.com/button/ を参照してください。
●実行前～実行後 ※プログラム実行後、点数一覧の個別合計点とランク表を元に、個別にランク付けされました。
EXCEL VBA 名前の一覧表からフリガナ毎（ア行・カ行・・）に名前を振り分ける
●プログラム説明 （サンプルプログラム③）
下記のサンプルプログラムは、シート「氏名一覧」にあるフリガナ情報を元に、別シートにあ行・カ行・サ行・・・毎に、名前（フリガナ）情報を振り分けるサンプルプログラムです。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
Sub フリガナ別振分() Dim ws01, ws02 As Worksheet Dim I, L, lRow, mRow, xRow, mCol As Long Dim Furigana As String Set ws01 = Worksheets("氏名一覧") Set ws02 = Worksheets("フリガナ分け") lRow = ws02.UsedRange.Rows.Count mCol = ws02.Cells(1, Columns.Count).End(xlToLeft).Column 'シート「フリガナ分け」１行目の最終列を取得 ws02.Range(Cells(2, "A"), Cells(lRow + 2, mCol)).Clear 'シート「フリガナ分け」の元データをクリアー lRow = ws01.Cells(Rows.Count, "A").End(xlUp).Row 'シート「点数ランク分け」のランク表の最終行を取得 For L = 1 To mCol 'シート「フリガナ分け」の１行名にア行・カ行・・指定した分ループする。 Furigana = ws02.Cells(1, L) 'Furiganaに[ア－オ]・・・などを順番に設定する。 xRow = 2 For I = 2 To lRow '’シート「氏名一覧」から全員分データをループする。 If ws01.Cells(I, "C") Like Furigana & "*" Then 'シート「氏名一覧」にあるフリガナとFurigana「アーオ」・が該当するか比較する。 ws02.Cells(xRow, L) = ws01.Cells(I, "C") '一致しらた名前を該当する列「アーオ」・「カーコ」・・に転記する。 xRow = xRow + 1 '転記先の行数に加算＋１ End If Next I Next L lRow = ws02.UsedRange.Rows.Count With ws02.Range(Cells(1, "A"), Cells(lRow, mCol)) .Borders.LineStyle = xlContinuous 'シート「点数ランク分け」に転記されたデータの最終行まで罫線を引く .Font.Size = 8 ' 'シート「点数ランク分け」に転記されたデータの文字列フォントを８サイズに変更 End With End Sub |
●実行前～実行後 ※プログラム実行後、シート「氏名一覧」のフリガナ情報より、項目で設定された「アーオ行・カーコ行・・」毎にフリガナ情報が振り分けられました。
最後まで、ご覧いただきまして誠に有難うございました。
また、VBAに関するテクニックや便利な手法などをこのサイトに掲載していきますので、定期的に参照していただけると幸いです。
また、VBAに関するテクニックや便利な手法などをこのサイトに掲載していきますので、定期的に参照していただけると幸いです。