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

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

MENU

【ノーコードVBA】複数セルの転記を転記表を使い行う

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

例として「複数セルの転記を転記表を使い行う  」VBAマクロを作成します。

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

事例

コピーのマクロの多くは「最終行の下」に貼り付けるパターンです。

本事例は、指定した行のデータをコピーし、指定した行への貼り付けを、複数箇所でおこないます。

利用する転記表

アプリの設定

アプリの設定です。

アプリのトップページ 

⇒▼コピー・貼り付け

⇒【ツール】転記表で、複数セルの転記を行う



【ポイント】

■ 本事例では、同じシート間の処理ですが、別シートや別ブックでも処理可能です。

■ 2列ごとにデータをコピーし、3列ごとに貼り付けることも可能です。

表示されるVBAコード 

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

 

VBAコードを見る

Sub デモ_46() '転記表で、複数セルの転記を行う
 Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False  ' 警告表示を停止

Dim リスト  As Variant, 行 As Long
'リストを配列に入れる
リスト = Workbooks("転記デモ").Worksheets("転記マスタ").Range("a1").CurrentRegion.Value
'列数をチェック
If UBound(リスト, 2) <> 8 Then
    MsgBox "8列ではないので、終了します。"
    Exit Sub
End If
'ブックが開いているか確認
Dim ブック As Workbook, 印1 As Boolean, 印2 As Boolean
印1 = False
印2 = False
For Each ブック In Workbooks
    If Left(ブック.Name, InStrRev(ブック.Name, ".") - 1) = リスト(2 + 1, 1) Then
        印1 = True
    End If
    If Left(ブック.Name, InStrRev(ブック.Name, ".") - 1) = リスト(2 + 1, 6) Then
        印2 = True
    End If
Next
'ブックが開いていないときは終了
If 印1 <> True Or 印2 <> True Then
    MsgBox "対象ブックが開いていないので、終了します"
    Exit Sub
End If
'転記先シートを開く
Workbooks(リスト(2 + 1, 6)).Activate
Worksheets(リスト(2 + 1, 7)).Select
'リストの1行目から最終行まで転記
For 行 = 2 + 1 To UBound(リスト, 1)
    'コピー元を横も縦も広げない場合
    If リスト(行, 5) = Empty And リスト(行, 4) = Empty Then
        Workbooks(リスト(行, 6)).Worksheets(リスト(行, 7)).Range(リスト(行, 8)).Value _
        = Workbooks(リスト(行, 1)).Worksheets(リスト(行, 2)).Range(リスト(行, 3)).Value
    'コピー元を縦に広げない場合
    ElseIf リスト(行, 5) = Empty Then
        Workbooks(リスト(行, 6)).Worksheets(リスト(行, 7)).Range(リスト(行, 8)).Resize(, リスト(行, 4)).Value _
        = Workbooks(リスト(行, 1)).Worksheets(リスト(行, 2)).Range(リスト(行, 3)).Resize(, リスト(行, 4)).Value
    'コピー元を横に広げない場合
    ElseIf リスト(行, 4) = Empty Then
        Workbooks(リスト(行, 6)).Worksheets(リスト(行, 7)).Range(リスト(行, 8)).Resize(リスト(行, 5)).Value _
        = Workbooks(リスト(行, 1)).Worksheets(リスト(行, 2)).Range(リスト(行, 3)).Resize(リスト(行, 5)).Value
    Else
        Workbooks(リスト(行, 6)).Worksheets(リスト(行, 7)).Range(リスト(行, 8)).Resize(リスト(行, 5), リスト(行, 4)).Value _
        = Workbooks(リスト(行, 1)).Worksheets(リスト(行, 2)).Range(リスト(行, 3)).Resize(リスト(行, 5), リスト(行, 4)).Value
    End If
Next 行
Application.DisplayAlerts = True   ' 警告表示を再開
Application.ScreenUpdating = True  ' 画面描画を再開
End Sub

 

ChatGPTで修正

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

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