【新発想】ノーコードでExcelを自動化する無料ツール

コードの知識不要😊 VBAコードを表示する無料アプリです。 ChatGPTの併用で、できることは無限です。

MENU

【ノーコードVBA】データの文字列や〇印を既存のクロス表にいれる

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

例として、アプリで「データの文字列や〇印を既存のクロス表にいれる」VBAマクロを作成します。

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

事例 右側のクロス表に、文字列を転記する

マクロを実行すると、離れたセルの値がリスト化されました。

10月3日のシフトBが、空いていることがわかります。

また、ダブりもメッセージを出すことができます。

アプリの設定

アプリのトップページ

 ⇒▼表形式の変換
 ⇒リスト形式を

 ⇒【ツール】縦のリスト形式のデータを、既存のマトリックス表に転記する


【ポイント】

■ 【4】リストの見出しが重複するときは、エラーメッセージを出して、中止できます。

表示されるVBAコード 

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

 

VBAコードを見る

Sub デモ_126() '縦のリスト形式のデータを、既存のマトリックス表に転記する
 Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False  ' 警告表示を停止

Dim リスト  As Variant, 行見出し As Range, 列見出し As Range
Dim j As Long, 行 As Long, 列 As Long
'リストを配列に入れる
Worksheets("データ").Select
リスト = Range("a1").CurrentRegion.Value
'見出しを取得する
Worksheets("データ").Select
Set 行見出し = Range(Range("f2").Offset(0, -1), Range("f2").Offset(0, -1).End(xlDown))
Set 列見出し = Range(Range("f2").Offset(-1, 0), Range("f2").Offset(-1, 0).End(xlToRight))
'見出しに、項目の漏れがないかチェック
For j = 2 To UBound(リスト, 1)
    If 行見出し.Find(リスト(j, 1)) Is Nothing Then
        MsgBox リスト(j, 1) & vbCrLf & "が見出しにありません。" & vbCrLf & "見出しの漏れと位置を確認してください" & vbCrLf & "終了します"
        Exit Sub
    End If
    If 列見出し.Find(リスト(j, 2)) Is Nothing Then
        MsgBox リスト(j, 2) & vbCrLf & "が見出しにありません。" & vbCrLf & "見出しの漏れと位置を確認してください" & vbCrLf & "終了します"
         Exit Sub
    End If
Next j
'重複チェック
Dim 辞書 As Object
Set 辞書 = CreateObject("Scripting.Dictionary")
Worksheets("データ").Select
For 行 = LBound(リスト, 1) To UBound(リスト, 1)
    If 辞書.Exists(リスト(行, 1) & リスト(行, 2)) Then
        MsgBox リスト(行, 1) & リスト(行, 2) & vbCrLf & "が重複しています。" & vbCrLf & "終了します"
        Exit Sub
    Else
        辞書.Add リスト(行, 1) & リスト(行, 2), ""
    End If
Next 行
辞書.RemoveAll
'既存データクリア
On Error Resume Next '空白対策
Worksheets("データ").Select
行見出し.Offset(0, 1).Resize(, 列見出し.Columns.Count).SpecialCells(xlCellTypeConstants, 3).ClearContents
On Error GoTo 0
'値を転記
For j = 2 To UBound(リスト, 1)
    行 = 行見出し.Find(リスト(j, 1)).Row
    列 = 列見出し.Find(リスト(j, 2)).Column
    Cells(行, 列).Value = リスト(j, 3)
Next j
Application.DisplayAlerts = True   ' 警告表示を再開
Application.ScreenUpdating = True  ' 画面描画を再開
End Sub

 

ChatGPTで修正

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

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