【ノーコード】1分でExcelを自動化する無料ツール

コードの知識不要😊ChatGPTしようぜ⚾17

MENU

【ノーコードVBA】フィルターで項目別に別々のシートに分ける

エクセルVBAマクロを自動作成する無料アプリです。

例として「フィルターで項目別に別々のシートに分ける」VBAマクロを作成します。

 ・新規シートを追加し転記、もしくは、既存シートの下に転記します。

 ・最終行が変動する表に対応。

 ・一部の列のみ転記可能。

 ・フォーマットとなる原本に転記可能。

 

(ページの末尾に、VBAコード掲載)

事例1 郵便番号簿を、市区町村別のシートに分ける

各区別にデータが分かれました😀

アプリの設定

アプリのトップページ 

⇒ ▼表形式の変換

⇒ 【ツール】データを項目別シートに分ける

表示されるVBAコード 

アプリで作成されたコードを、VBE画面に貼り付ければ、マクロの完成です。

 

VBAコードを見る

Sub デモ() '項目ごとに定型シート作成 
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False  ' 警告表示を停止
Dim セル範囲 As String, セル As Range, 右下セル As String
Sheets("Sheet1").Select
'表の最終行を決定
Dim 最終行 As Long
最終行 = Cells(Rows.Count, Range("A1").Column).End(xlUp).Row
セル範囲 = "a1" & ":" & Cells(最終行, Range("d1").Column).Address(False, False)

Range(セル範囲).Select
Application.Calculation = xlCalculationManual '自動計算を停止
'◆キーをつくる
Dim 辞書 As Object, キー As Variant, 最終行2 As Long, 行 As Long
Set 辞書 = CreateObject("Scripting.Dictionary")
最終行2 = Sheets("Sheet1").Cells(Rows.Count, Range("a1").Column).End(xlUp).Row
For 行 = Range("a1").Row + 1 To 最終行2
    キー = Sheets("Sheet1").Cells(行, Range("a1").Column + 3 - 1).Value
    If Not 辞書.Exists(キー) Then
      辞書.Add キー, ""
    End If
Next
'◆キーごとにデータを貼り付ける
For Each キー In 辞書
    '◆フィルタ
    Sheets("Sheet1").Select
    Range(セル範囲).AutoFilter Field:=3, Criteria1:=キー
     '◆コピーする列の確定
Dim 重なり As Range
Set 重なり = Range(セル範囲)
    '◆シート名があるかチェック
    Dim シート As Worksheet
    For Each シート In Worksheets
        If シート.Name = キー Then
            '◆コピー
            重なり.Copy
            Sheets("Sheet1").AutoFilterMode = False
            Sheets(キー).Select
            Range("a1").Select
            '◆貼り付け行
            Dim 左端列 As Long, 下端行 As Long, 相手セル As String
            左端列 = ActiveCell.Column
            下端行 = Selection.CurrentRegion.Row + Selection.CurrentRegion.Rows.Count - 1
            相手セル = Cells(下端行, 左端列).Address(False, False)
            If Range(相手セル).Value <> "" Then
               相手セル = Cells(下端行 + 1, 左端列).Address(False, False)
            End If
            '◆貼り付け
            Range(相手セル).PasteSpecial xlPasteAll
            GoTo 次の項目
        End If
    Next シート
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = キー
    '◆コピー
    重なり.Copy
    Sheets("Sheet1").AutoFilterMode = False
    '◆貼り付け
    Sheets(キー).Range("a1").PasteSpecial xlPasteAll
次の項目:
Next キー
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic ' 自動計算を再開
Application.DisplayAlerts = True   ' 警告表示を再開
Application.ScreenUpdating = True  ' 画面描画を再開
End Sub

 

事例2 左のデータを右の"原本"に貼り付け、支店別シートを作成

支店別に、「書式」に貼り付けました。

できました😀

応用事例1

既存のシートがあるときは、既存データの下に貼り付けできます。

応用事例2

単票形式の表に、各データを差し込みたいときは、貼り付けデータを参照する関数を、差し込み場所に入力しておきます。(貼り付けデータは、単票の範囲外にします)

 

アプリの設定

アプリのトップページ 

⇒ ▼表形式の変換

⇒ 【ツール】データを項目別シートに分ける



【ポイント】

 転記先の原本シートには、見出しがあるので、「転記先の左上セル」は2行目(A2)にし、「転記データに見出しを含めない」に☑をいれます。

 たとえば、下の例のように、原本に請求書のフォーマットを使うことができます

 

■ 上の例で、「指定した列を転記する」を選び、「B:F」と指定すると、

A列(納品先名)を除いた、B列からF列をコピーします。

 

表示されるVBAコード 

アプリで作成されたコードを、VBE画面に貼り付ければ、マクロの完成です。

 

VBAコードを見る

Sub デモ_94() '項目ごとに定型シート作成 
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False  ' 警告表示を停止
Dim セル範囲 As String, セル As Range, 右下セル As String
Sheets("データ").Select
'◆最終行を取得し、セル範囲を決める
With Range("a1:f1").CurrentRegion
      右下セル = Cells(.Row + .Rows.Count - 1, Range("f1").Column).Address(False, False)
End With
セル範囲 = "a1" & ":" & 右下セル

Range(セル範囲).Select
Call デモ_94_メイン処理(セル範囲)
Application.DisplayAlerts = True   ' 警告表示を再開
Application.ScreenUpdating = True  ' 画面描画を再開
End Sub


Sub デモ_94_メイン処理(セル範囲 As String)
Application.Calculation = xlCalculationManual '自動計算を停止
'◆キーをつくる
Dim 辞書 As Object, キー As Variant, 最終行 As Long, 行 As Long
Set 辞書 = CreateObject("Scripting.Dictionary")
最終行 = Sheets("データ").Cells(Rows.Count, Range("a1").Column).End(xlUp).Row
For 行 = Range("a1").Row + 1 To 最終行
    キー = Sheets("データ").Cells(行, Range("a1").Column + 2 - 1).Value
    If Not 辞書.Exists(キー) Then
      辞書.Add キー, ""
    End If
Next
'◆キーごとにデータを貼り付ける
For Each キー In 辞書
    '◆フィルタ
    Sheets("データ").Select
    Range(セル範囲).AutoFilter Field:=2, Criteria1:=キー
     '◆コピーする列の確定
Dim 重なり As Range
Set 重なり = Range(セル範囲).Offset(1, 0).Resize(Selection.Rows.Count - 1)
    '◆シート名があるかチェック
    Dim シート As Worksheet
    For Each シート In Worksheets
        If シート.Name = キー Then
            '◆コピー
            重なり.Copy
            Sheets("データ").AutoFilterMode = False
            Sheets(キー).Select
            Range("a2").Select
            '◆貼り付け行
            Dim 左端列 As Long, 下端行 As Long, 相手セル As String
            左端列 = ActiveCell.Column
            下端行 = Selection.CurrentRegion.Row + Selection.CurrentRegion.Rows.Count - 1
            相手セル = Cells(下端行, 左端列).Address(False, False)
            If Range(相手セル).Value <> "" Then
               相手セル = Cells(下端行 + 1, 左端列).Address(False, False)
            End If
            '◆貼り付け
            Range(相手セル).PasteSpecial Paste:=xlPasteValues
            GoTo 次の項目
        End If
    Next シート
    Worksheets("書式").Copy after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = キー
    '◆コピー
    重なり.Copy
    Sheets("データ").AutoFilterMode = False
    '◆貼り付け
    Sheets(キー).Range("a2").PasteSpecial Paste:=xlPasteValues
次の項目:
Next キー
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic ' 自動計算を再開
End Sub

 

ChatGPTで修正

あなたが自動化したい内容と事例が少し異なる場合は、無料で使えるマイクロソフトの「BingAIチャット」でコードを修正します。とても簡単です!

アプリはこちらから↓↓↓↓