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

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

MENU

【ノーコードVBA】転記表を使い、リスト形式の表に転記する

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

例として「転記表を使い、リスト形式の表に転記する 」VBAマクロを作成します。

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

事例 コピー元の値のコピー先への転記を、転記表で行う

 



 

転記表は、下図作業列(H、I列)を作成し、点線の部分を選択し下方向にドラッグします。セル範囲(C、F列)は作業列を参照します。

 

アプリの設定

アプリの設定です。

アプリのトップページ 

⇒▼コピー・貼り付け

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



表示されるVBAコード 

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

 

VBAコードを見る

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

Dim リスト  As Variant
'リストを配列に入れる
Dim 最終行 As Long
Workbooks("Book1").Worksheets("Sheet1").Select
最終行 = Range("a4").End(xlDown).Row
リスト = Range(Range("a4"), Cells(最終行, Range("a4").Column + 5)).Value
'列数をチェック
If UBound(リスト, 2) <> 6 Then
    MsgBox "転記表が6列ではないので、終了します。"
    Exit Sub
End If
'ブックが開いているか確認
Dim ブック As Workbook, 印1 As Boolean, 印2 As Boolean
For Each ブック In Workbooks
    If Left(ブック.Name, InStrRev(ブック.Name, ".") - 1) = リスト(1, 1) Then
        印1 = True
    End If
    If Left(ブック.Name, InStrRev(ブック.Name, ".") - 1) = リスト(1, 4) Then
        印2 = True
    End If
Next
If 印1 <> True Or 印2 <> True Then
    MsgBox "対象ブックが開いていないので、終了します"
    Exit Sub
End If
'リストの1行目から最終行まで転記
Application.Calculation = xlCalculationManual
Dim 終了行 As Long, 行 As Long, コピー元 As Range, 転記先 As Range
For 行 = 1 To UBound(リスト, 1)
    If Workbooks(リスト(行, 1)).Worksheets(リスト(行, 2)).Range(リスト(行, 3)).Row > _
    Workbooks(リスト(行, 1)).Worksheets(リスト(行, 2)).Cells(Rows.Count, Range(リスト(行, 3)).Column).End(xlUp).Row Then GoTo Continue
    Set コピー元 = Workbooks(リスト(行, 1)).Worksheets(リスト(行, 2)).Range(リスト(行, 3))
    Set 転記先 = Workbooks(リスト(行, 4)).Worksheets(リスト(行, 5)).Range(リスト(行, 6))
    転記先 = コピー元.Value
Continue:
Next 行
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True   ' 警告表示を再開
Application.ScreenUpdating = True  ' 画面描画を再開
End Sub

 

コピー先の空白行を削除するコードはこちら

ChatGPTで修正

コードの改変は、無料で使えるマイクロソフトの「BingAIチャット」を使います。
とても簡単です!

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