www.smiyasaka.com は、 2019 年2月から SSL 化し 通信を暗号化した方式で発信をしています。

● Excel マクロの解説 「 転記マクロ 」編 ●


「 自動転記マクロ 」について、簡単ですが赤字で解説を入れました。
 参考になれば、幸いです。
 2019.11.07 現在
----------------------------------------------------------------------------------

thisWorkbook のプログラム

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    SAA02リセット
End Sub
Sub auto_open()は、下記が実行されてから、実行されます。
アドインメニューの表示
Private Sub Workbook_Open()

SAA02セット

End Sub

---------------------------------------------------------------------------------

UForm1 のプログラム

Private Sub CommandButton1_Click()           <---- [ 読 込 ] ボタンの処理
    ' [ マクロの表紙]へブック名・シート名保存
    F1name = ActiveWorkbook.Name
    R1name = ActiveSheet.Name
    Workbooks(AAname).Worksheets(BBname).Cells(20, 2).Value = F1name
    Workbooks(AAname).Worksheets(BBname).Cells(20, 3).Value = R1name

    データ読込
End Sub

Private Sub CommandButton2_Click()           <---- [ 書 込 ] ボタンの処理
    ' [ マクロの表紙]へブック名・シート名保存
    F2name = ActiveWorkbook.Name
    R2name = ActiveSheet.Name
    Workbooks(AAname).Worksheets(BBname).Cells(21, 2).Value = F2name
    Workbooks(AAname).Worksheets(BBname).Cells(21, 3).Value = R2name

    データ書込
End Sub

Private Sub CommandButton7_Click()           <---- [ 読込元] ボタンの処理
    ' [ マクロの表紙]へブック名・シート名保存
    F1name = ActiveWorkbook.Name
    R1name = ActiveSheet.Name
    Workbooks(AAname).Worksheets(BBname).Cells(20, 2).Value = F1name
    Workbooks(AAname).Worksheets(BBname).Cells(20, 3).Value = R1name
    
    YY = ActiveWindow.Selection(1).Row          <---- [選択された範囲の縦先頭位置を取得
    YC = ActiveWindow.Selection.Rows.Count      <---- [縦範囲 セル個数を取得
    XX = ActiveWindow.Selection(1).Column       <---- [選択された範囲の横先頭位置を取得

    Workbooks(AAname).Worksheets(BBname).Cells(24, 2).Value = YY
    Workbooks(AAname).Worksheets(BBname).Cells(24, 3).Value = XX
    Workbooks(AAname).Worksheets(BBname).Cells(25, 2).Value = YC
    
End Sub

Private Sub CommandButton8_Click()           <---- [ 書込先 ] ボタンの処理
    ' [ マクロの表紙]へブック名・シート名保存
    F2name = ActiveWorkbook.Name
    R2name = ActiveSheet.Name
    Workbooks(AAname).Worksheets(BBname).Cells(21, 2).Value = F2name
    Workbooks(AAname).Worksheets(BBname).Cells(21, 3).Value = R2name
    Workbooks(AAname).Worksheets(BBname).Cells(28, 2).Value _
            = ActiveWindow.Selection(1).Row     <---- 選択された範囲の縦先頭位置を取得
    
    自動データ転記1
    
End Sub



Private Sub CommandButton9_Click()           <---- [ 分割表示 ] ボタンの処理
    ' 分割表示
    Windows.Arrange ArrangeStyle:=xlVertical <---- 左右分割表示
    
End Sub


Private Sub CommandButton9_Click()  <---- [ 分割表示 ] ボタンの処理・
                                                    分割有/無を切り替える
    ' [ マクロの表紙]のセル位置(22,2)を分割表示の有無スイッチとして使う。
    ' 分割表示/分割解除
    If Workbooks(AAname).Worksheets(BBname).Cells(22, 2).Value = 0 Then
        Workbooks(AAname).Worksheets(BBname).Cells(22, 2).Value = 1
        UForm1.CommandButton9.Caption = "分割解除"
        '全画面で、横方向に並べて表示
       'Windows.Arrange ArrangeStyle:=xlVertical         <---- 左右分割表示
        Windows.Arrange xlArrangeStyleVertical
    Else
        Workbooks(AAname).Worksheets(BBname).Cells(22, 2).Value = 0
        Application.WindowState = xlMaximized   '最大化  <---- 表示を最大化し、元に戻す
        UForm1.CommandButton9.Caption = "分割表示"
    End If

End Sub

    'ここからは、逆方向への転記処理をする処理

Private Sub CommandButton10_Click()           <---- [ 読込元] ボタンの処理
    ' [ マクロの表紙]へブック名・シート名保存
    F2name = ActiveWorkbook.Name
    R2name = ActiveSheet.Name
    Workbooks(AAname).Worksheets(BBname).Cells(21, 2).Value = F2name
    Workbooks(AAname).Worksheets(BBname).Cells(21, 3).Value = R2name
    Workbooks(AAname).Worksheets(BBname).Cells(28, 2).Value _
         = ActiveWindow.Selection(1).Row           ' 縦先頭位置
    
    自動データ転記2
    
End Sub

Private Sub CommandButton11_Click()           <---- [ 書込先 ] ボタンの処理
    ' [ マクロの表紙]へブック名・シート名保存
    F1name = ActiveWorkbook.Name
    R1name = ActiveSheet.Name
    Workbooks(AAname).Worksheets(BBname).Cells(20, 2).Value = F1name
    Workbooks(AAname).Worksheets(BBname).Cells(20, 3).Value = R1name
    
    YY = ActiveWindow.Selection(1).Row           ' 縦先頭位置
    YC = ActiveWindow.Selection.Rows.Count       ' 縦範囲 セル個数
    XX = ActiveWindow.Selection(1).Column        ' 横先頭位置
    XC = ActiveWindow.Selection.Columns.Count    ' 横範囲 セル個数

    Workbooks(AAname).Worksheets(BBname).Cells(24, 2).Value = YY
    Workbooks(AAname).Worksheets(BBname).Cells(24, 3).Value = XX
    Workbooks(AAname).Worksheets(BBname).Cells(25, 2).Value = YC
   
End Sub

Private Sub UserForm_Initialize()
    '  ユーザーフォームを表示したブック名を保存
    Workbooks(AAname).Worksheets(BBname).Cells(18, 2).Value = ActiveWorkbook.Name
    Workbooks(AAname).Worksheets(BBname).Cells(18, 3).Value = ActiveSheet.Name
    
    Workbooks(AAname).Worksheets(BBname).Cells(22, 2).Value = 0
    UForm1.CommandButton9.Caption = "分割表示"
  
End Sub

---------------------------------------------------------------------------------
Module1 のプログラム

    Public x, y, Tate, Yoko As Integer
    Public M, MM, N, YY, YC, XX, XC, KYY As Integer
    ' N の値を変えると読み書きのデータ数が変更できます。
    Public Const NN As Integer = 11       <---- 転記可能セルの最大数
    ' 本マクロのブック名 変更しないこと
    Public Const AAname As String = "転記マクロ.xlsm"
    Public Const BBname As String = "表紙"

    Public AAA, BBB, CCC, F1name, R1name, F2name, R2name As String
    Public StartDay, EndDay, YX_ichi As String
    ' 読取・書込用変数は、すべての型式に対応させるため、Variant にしています。
    Public Rdata(20) As Variant

Excelブックがオープンし、マクロが実行された時に自動で実行されるサブルーチン
Sub auto_open()
    *****************************************************
     Excel 起動時にメニューバーをアドインに移動させる処理
    *****************************************************

    この様にしないといつまでも Excelブックがオープンしない
    
    Application.OnTime Now + TimeValue("00:00:00"), "AddIN"    <---- タイムディレー処理
                                                  直ぐに、サブルーチン AddIN を実行させる
End Sub

---------------------------------------------------------------------------------

メニューバーを「アドイン」に移動させる処理
Sub AddIN()
    Sheets(CCname).Select            <---- 所定のシートを表示させる
    N = Val(Application.Version)     <---- Excelのバージョンを取得する
     
    Excelのバージョンの"2000 ; 9","2002 ; 10","2003 ; 11"時は、何もしない
    If N = 9 Or N = 10 Or N = 11 Then Exit Sub
    
    Excelのバージョンの"2007 ; 12","2010 ; 14","2013 ; 15","2016 ; 16"時は、アドインに移動
    Application.SendKeys ("%X%")     <---- [ALT]-->[X]-->[ALT]のキー入力を実行
     '---------------------------------------------------------------------
     〇〇〇〇に文字を書込むとタイトルのMicrosoftExcelの文字が入れ替わります。
     Application.Caption = " 〇〇〇〇"
     '---------------------------------------------------------------------
End Sub

Sub UForm1表示()
    UForm1.Show vbModeless    <---- ユーザーフォーム UForm1 を表示する。
End Sub

Sub SAA02セット()     <---- アドインメニューを表示する。
     Dim Mycontrol As CommandBarControl, mysubmenu As CommandBarControl

     Application.CommandBars("Worksheet Menu Bar").Reset <---- 事前にアドインメニューを
                                                                       消去する。
     Set Mycontrol = CommandBars("Worksheet Menu Bar"). _
     Controls.Add(msoControlPopup)
     Mycontrol.Caption = "(■)"
     Mycontrol.OnAction = "UForm1表示"
End Sub

Sub SAA02リセット()
    Application.CommandBars("Worksheet Menu Bar").Reset <---- すべてのアドインメニューを
                                                                       消去する。
    ' ブック名・シート名保存場所リセット
    Workbooks(AAname).Worksheets(BBname).Cells(20, 2).Value = ""
    Workbooks(AAname).Worksheets(BBname).Cells(20, 3).Value = ""
    Workbooks(AAname).Worksheets(BBname).Cells(21, 2).Value = ""
    Workbooks(AAname).Worksheets(BBname).Cells(21, 3).Value = ""
End Sub

Sub データ読込()
    ' ブック名・シート名復旧
    F1name = Workbooks(AAname).Worksheets(BBname).Cells(20, 2).Value
    R1name = Workbooks(AAname).Worksheets(BBname).Cells(20, 3).Value


    For N = 1 To NN      ' NN : 読取・書込データ数
    
        R_ichi  ' 読込み位置 y, x 取得
        ' 指定が無かったら終了
        If x = 0 Then Exit For

        Rdata(N) = Workbooks(F1name).Worksheets(R1name).Cells(y, x).Value

    Next N
        ' ユーザーフォーム上に読込んだデータの一部を表示する。
        UForm1.Label3.Caption = Rdata(1) & " " & Rdata(2) & " " & Rdata(3)
        
End Sub

Sub R_ichi()

    y = ActiveWindow.RangeSelection.Rows.Row
    x = Workbooks(AAname).Worksheets(BBname).Cells(3, 10 + N).Value
    
End Sub

---------------------------------------------------------------------------------

Sub データ書込()
    ' ブック名・シート名復旧
    F1name = Workbooks(AAname).Worksheets(BBname).Cells(20, 2).Value
    R1name = Workbooks(AAname).Worksheets(BBname).Cells(20, 3).Value

    For N = 1 To NN      ' NN : 読取・書込データ数
    
        W_ichi  ' 書込み位置 y, x 取得
        
        ' 指定が無かったら終了
        
        If x = 0 Then Exit For
        
        Workbooks(F2name).Worksheets(R2name).Cells(y, x).Value = Rdata(N)
        
    Next N
    
End Sub

Sub W_ichi()

    y = ActiveWindow.RangeSelection.Rows.Row
    x = Workbooks(AAname).Worksheets(BBname).Cells(4, 10 + N).Value
    
End Sub

'==============================================================================
'     指定した範囲のデータを自動ですべて転記する。
'==============================================================================

Sub 自動データ転記1()
    ' ブック名・シート名復旧
    F1name = Workbooks(AAname).Worksheets(BBname).Cells(20, 2).Value
    R1name = Workbooks(AAname).Worksheets(BBname).Cells(20, 3).Value
    Workbooks(F1name).Activate
    Worksheets(R1name).Activate
    ' ユーザーフォームからフォーカス(アクティブ)をブックに移す処理
    VBA.AppActivate Excel.Application.Caption
    
    ' 抽出データの最終行を検索する。
    YY = Workbooks(AAname).Worksheets(BBname).Cells(24, 2).Value
    M = Workbooks(AAname).Worksheets(BBname).Cells(25, 2).Value
    KYY = Workbooks(AAname).Worksheets(BBname).Cells(28, 2).Value
    
    For MM = 1 To M      ' NN : 読取・書込データ数
    
        y = YY         ' 読込先縦位置指定
            
        自動データ読込1
        自動データ書込1

        KYY = KYY + 1      ' 書込先縦位置更新
        YY = YY + 1        ' 読込先縦位置更新
        
    Next MM
    
End Sub

Sub 自動データ読込1()

    F1name = Workbooks(AAname).Worksheets(BBname).Cells(20, 2).Value
    R1name = Workbooks(AAname).Worksheets(BBname).Cells(20, 3).Value
    Workbooks(F1name).Activate
    Worksheets(R1name).Activate
    ' ユーザーフォームからフォーカス(アクティブ)をブックに移す処理
    VBA.AppActivate Excel.Application.Caption
    
    For N = 1 To NN          ' NN : 読取・書込データ数
    
        x = Workbooks(AAname).Worksheets(BBname).Cells(3, 10 + N).Value
        
     ' 指定が無かったら終了
        If x = 0 Then Exit For

        Rdata(N) = Workbooks(F1name).Worksheets(R1name).Cells(y, x).Value
 
    Next N
        
End Sub

Sub 自動データ書込1()

    F2name = Workbooks(AAname).Worksheets(BBname).Cells(21, 2).Value
    R2name = Workbooks(AAname).Worksheets(BBname).Cells(21, 3).Value
    Workbooks(F2name).Activate
    Worksheets(R2name).Activate
    ' ユーザーフォームからフォーカス(アクティブ)をブックに移す処理
    VBA.AppActivate Excel.Application.Caption
    
    For N = 1 To NN          ' NN : 読取・書込データ数
    
        x = Val(Workbooks(AAname).Worksheets(BBname).Cells(4, 10 + N).Value)
        
        ' 指定が無かったら終了
        
        If x = 0 Then Exit For
        
        Workbooks(F2name).Worksheets(R2name).Cells(KYY, x).Value = Rdata(N)

    Next N
    
End Sub

---------------------------------------------------------------------------------
'==============================================================================
'     指定した範囲のデータを自動ですべて転記する。(上記の逆位置への転記)
'==============================================================================

Sub 自動データ転記2()

    ' 書込み側の位置情報で読込・読込側の位置情報で書き込む
    F1name = Workbooks(AAname).Worksheets(BBname).Cells(20, 2).Value
    R1name = Workbooks(AAname).Worksheets(BBname).Cells(20, 3).Value
    Workbooks(F1name).Activate
    Worksheets(R1name).Activate
    ' ユーザーフォームからフォーカス(アクティブ)をブックに移す処理
    VBA.AppActivate Excel.Application.Caption
    
    ' 抽出データの最終行を検索する。
    YY = Workbooks(AAname).Worksheets(BBname).Cells(24, 2).Value
    M = Workbooks(AAname).Worksheets(BBname).Cells(25, 2).Value
    KYY = Workbooks(AAname).Worksheets(BBname).Cells(28, 2).Value
    
    For MM = 1 To M
    
        y = YY         ' 読込先縦位置指定
            
        自動データ読込2
        自動データ書込2

        KYY = KYY + 1      ' 書込先縦位置更新
        YY = YY + 1        ' 読込先縦位置更新
        
    Next MM
    
End Sub

Sub 自動データ読込2()

    F1name = Workbooks(AAname).Worksheets(BBname).Cells(20, 2).Value
    R1name = Workbooks(AAname).Worksheets(BBname).Cells(20, 3).Value
    Workbooks(F1name).Activate
    Worksheets(R1name).Activate
    ' ユーザーフォームからフォーカス(アクティブ)をブックに移す処理
    VBA.AppActivate Excel.Application.Caption
    
    For N = 1 To NN          ' NN : 読取・書込データ数
    
        x = Workbooks(AAname).Worksheets(BBname).Cells(4, 10 + N).Value
        
        ' 指定が無かったら終了
        If x = 0 Then Exit For

        Rdata(N) = Workbooks(F1name).Worksheets(R1name).Cells(y, x).Value
 
    Next N
        
End Sub

Sub 自動データ書込2()

    F2name = Workbooks(AAname).Worksheets(BBname).Cells(21, 2).Value
    R2name = Workbooks(AAname).Worksheets(BBname).Cells(21, 3).Value
    Workbooks(F2name).Activate
    Worksheets(R2name).Activate
    ' ユーザーフォームからフォーカス(アクティブ)をブックに移す処理
    VBA.AppActivate Excel.Application.Caption
    
    For N = 1 To NN      ' NN : 読取・書込データ数
    
        x = Val(Workbooks(AAname).Worksheets(BBname).Cells(3, 10 + N).Value)
        
        ' 指定が無かったら終了
        
        If x = 0 Then Exit For
        
        Workbooks(F2name).Worksheets(R2name).Cells(KYY, x).Value = Rdata(N)

    Next N
    
End Sub

---------------------------------------------------------------------------------

TOPへ戻る