| 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 As String
Public F2name, R2name As String
Public StartDay, EndDay, YX_ichi As String
' 読取・書込用変数は、すべての型式に対応させるため、
Variant にしています。
Public Rdata(20) As Variant
Excelブックがオープンし、マクロが実行された時に自動で実行される
サブルーチン
Sub auto_open()
'----------------------------------------------------
' Excel 起動時にメニューバーをアドインに移動させる処理
'----------------------------------------------------
この様にしないといつまでも Excelブックがオープンしない
' タイムディレー処理 直ぐに、サブルーチン AddIN を実行させる
Application.OnTime Now + TimeValue("00:00:00"), "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"時は、アドインに移動
' [ALT]-->[X]-->[ALT]のキー入力を実行
Application.SendKeys ("%X%")
'------------------------------------------------------------
〇〇〇〇に文字を書込むとタイトルの
MicrosoftExcelの文字が入れ替わります。
Application.Caption = " 〇〇〇〇"
'------------------------------------------------------------
End Sub
Sub UForm1表示()
UForm1.Show vbModeless <---- ユーザーフォーム UForm1 を表示する
End Sub
Sub SAA02セット() <---- アドインメニューを表示する。
Dim Mycontrol As CommandBarControl
Dim 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
-----------------------------------------------------------
|
|