【VBA×ChatGPT】1分でマクロを作り、1秒で処理完了

「VBAマクロを作成」するChatGPTプロンプトや、VBAコードを表示する無料アプリです。

MENU

複数シートのデータを、縦にコピーし、1枚にまとめる(複数シートから転記する)

「NoCodeVBA」にようこそ!
「NoCodeVBA」はエクセルVBAマクロを作成する無料アプリです。

 

例として「複数シートのデータを、縦方向にコピーし、1枚にまとめる」VBAマクロを作成します。

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

事例

各シートのデータを、1枚のシートにまとめます

1枚のシートに、データをまとめました。

できました(^^)/

アプリの設定

アプリの設定です。

アプリのトップページ 

⇒▼シート 

⇒【ツール】複数シートのデータを1枚のシートにまとめる

【ポイント】

 処理するシートのうち、「貼り付け先のシート」は自動で除外します。

 処理する範囲で、見出しを除いたセル(A2からF2)を選ぶことができます。

 範囲オプションで「最終行を除いて」を選ぶと、合計の行を除外できます。

 数式を、値で上書きできます。

表示されるVBAコード 

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

 Sub デモ_シートオプションあり() '複数シートを1枚
'◆"一覧"シートがあるか調べる
Dim 貼付シート As Worksheet, あり As Boolean
For Each 貼付シート In Worksheets
    If 貼付シート.Name = "一覧" Then 
        あり = True
        Exit For
    End If        
Next 貼付シート
'◆無ければ一覧"シートを追加
If あり = false Then
  Worksheets.Add before:=Worksheets(1)
  ActiveSheet.Name = "一覧"
End If
'◆各シートで処理をする
Dim シート As Worksheet
For Each シート In Worksheets
    Call デモ(シート)
Next シート
End Sub


Sub デモ(シート As Worksheet) '複数シートを1枚  
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False  ' 警告表示を停止
'◆シートが"一覧"ではない場合、"一覧"にデータを貼り付ける
Dim 右下セル As String, セル範囲 As String, 貼り付け先範囲 as Range, 貼り付け先セル As String 
    If シート.Name <> "一覧" Then
        '◆  コピーする範囲を取得
    シート.Select  
'◆最終行を取得し、セル範囲を決める          
Range("a1:f1").CurrentRegion.Select
右下セル = Cells(Selection.Row+ Selection.Rows.Count-1, Range("f1").Column).Address(False, False)
セル範囲 = "a1" & ":" & 右下セル

        '◆貼り付けが、見出し行ではないか確認
        Set 貼り付け先範囲 = Worksheets("一覧").Cells(Rows.Count, Range("b1").Column).End(xlUp).Resize(1, Range(セル範囲).Columns.Count)
        If  WorksheetFunction.CountBlank(貼り付け先範囲) = 貼り付け先範囲.Count Then
            シート.Range(セル範囲).Copy 
            Worksheets("一覧").Range("b1").PasteSpecial Paste:=xlPasteAll 
            Worksheets("一覧").Range("b1").PasteSpecial Paste:=xlPasteValues
            Worksheets("一覧").Range("b1").Offset(0, -1).Value = シート.Name
        Else
'表全体の末端を右下セルとして取得
Worksheets("一覧").Select
Range("b1").CurrentRegion.Select
右下セル = Cells(Selection.Row + Selection.Rows.Count - 1, Range("b1").Column).Address(False, False)            
貼り付け先セル = Worksheets("一覧").Range(右下セル).Offset(1, 0).Address(False, False)
            シート.Range(セル範囲).Copy 
            Worksheets("一覧").Range(貼り付け先セル).PasteSpecial Paste:=xlPasteAll                  
            Worksheets("一覧").Range(貼り付け先セル).PasteSpecial Paste:=xlPasteValues
            Worksheets("一覧").Range(貼り付け先セル).Offset(0, -1).Value = シート.Name
        End If         
    End If
Worksheets("一覧").activate                       
Application.DisplayAlerts = true   ' 警告表示を再開
Application.ScreenUpdating = True  ' 画面描画を再開           
End sub
   

手作業で数分かかる作業が、1秒で終わります。

ぜひ、アプリをご利用ください。

 

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

nocodevba.herokuapp.com