| |
例えば、以下の様なUserFormをモーダル表示で試して見たら？
UserFormに以下のコントロールを配置します
1、TextBox1：OpenしているBookのFullPathを表示
2、CommandButton1：OpenするBookを選択する為のダイアログ表示し、BookをOpen
3、CommandButton2：現在OpenしているBookをCloseする
4、ComboBox1：OpenしたBook（転記元）のシート選択
5、RefEdit1：転記元シートの範囲選択用
6、ComboBox2：マクロの在るBook（転記先）のシートを選択、若しくは新規シート作成
7、CommandButton3：転記実行ボタン
8、CommandButton4：UserFormを閉じるボタン
UzerFormが表示される時点で、TextBox1が""ならBook選択ダイアログが表示されるので
選択してOkすれば、BookがOpenされます
BookがOpenされると、そのBookの全シート名がComboBox1のListに設定されます
Copyするシートを選択し、RefEdit1にフォーカスが移れば、上記のシートで範囲選択が出来ます
次に、ComboBox2でList選択されればそのシートが転記先に選択され、
TextBox部に転記元に無いシート名を入れてEnterすれば、TextBox部の名前でシートが作成され転記先に成ります
RefEdit2は、転記先の転記位置を選択します
上記の各パラメタが揃えば、CommandButton3（実行ボタン）で転記が実行されます
CommandButton4は閉じるボタンで、もしBookが開いていた場合此れを閉じ、UserFormを閉じます
尚、RefEditのコントロールは、モードレスでは使えないと思います
Option Explicit
Private wkbOpen As Workbook
Private Sub UserForm_Activate()
If wkbOpen Is Nothing Then
CommandButton1_Click
End If
End Sub
Private Sub UserForm_Initialize()
Dim i As Long
With ThisWorkbook
For i = 1 To .Worksheets.Count
ComboBox2.AddItem .Worksheets(i).Name
Next i
End With
ComboBox1.Enabled = False
RefEdit1.Enabled = False
End Sub
Private Sub UserForm_Terminate()
Set wkbOpen = Nothing
End Sub
Private Sub ComboBox1_Change()
If ComboBox1.ListIndex = -1 Then
Exit Sub
End If
With wkbOpen.Worksheets(ComboBox1.Value)
.Activate
RefEdit1.Enabled = True
RefEdit1.Value = .UsedRange.Address(External:=True)
RefEdit1.SetFocus
End With
End Sub
Private Sub ComboBox2_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
If ComboBox2.Value <> "" And ComboBox2.ListIndex = -1 Then
If MsgBox("新規のシートをComboBoxの名前で作成します", vbOKCancel) = vbOK Then
With ThisWorkbook.Worksheets.Add
.Name = ComboBox2.Text
.Activate
End With
Else
Cancel = True
End If
Else
If ComboBox2.ListIndex > -1 Then
If MsgBox("既存のシートのデータを消去します", vbOKCancel) = vbOK Then
With ThisWorkbook.Worksheets(ComboBox2.Text)
.UsedRange.ClearContents
.Activate
End With
Else
Cancel = True
End If
End If
End If
RefEdit2.Enabled = True
End Sub
Private Sub ComboBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
With ComboBox2
If .Value <> "" And .ListIndex = -1 Then
.AddItem .Text
End If
End With
End Sub
Private Sub CommandButton1_Click()
Dim i As Long
Dim vntBook As Variant
If Not GetReadFile(vntBook, ThisWorkbook.Path, False, "OpenするBookを選択して下さい") Then
Exit Sub
End If
If StrComp(Dir(vntBook), ThisWorkbook.Name, vbTextCompare) = 0 Then
MsgBox "開こうとしているBookはマクロの在るこのBookです"
Exit Sub
End If
If wkbOpen Is Nothing Then
TextBox1.Text = vntBook
Set wkbOpen = Workbooks.Open(vntBook)
Else
If MsgBox("現在別のBookがOpenされていますのでCloseします", vbOKCancel) = vbOK Then
wkbOpen.Close
TextBox1.Text = vntBook
Set wkbOpen = Workbooks.Open(vntBook)
Else
Exit Sub
End If
End If
With ComboBox1
.Text = ""
.Clear
For i = 1 To wkbOpen.Worksheets.Count
.AddItem wkbOpen.Worksheets(i).Name
Next i
End With
ComboBox1.Enabled = True
RefEdit1.Enabled = False
End Sub
Private Sub CommandButton2_Click()
If Not wkbOpen Is Nothing Then
If MsgBox("現在のBookをCloseします", vbOKCancel) = vbOK Then
wkbOpen.Close
TextBox1.Text = ""
Set wkbOpen = Nothing
End If
End If
ComboBox1.Enabled = False
RefEdit1.Enabled = False
End Sub
Private Sub CommandButton3_Click()
Dim lngPos As Long
Dim vntCopy As Variant
Dim vntTo As Variant
If ComboBox2.ListIndex > -1 Then
vntCopy = RefEdit1.Value
lngPos = InStr(1, vntCopy, "!", vbBinaryCompare)
If lngPos > 0 Then
vntCopy = Mid(vntCopy, lngPos + 1)
End If
vntTo = RefEdit2.Value
lngPos = InStr(1, vntTo, "!", vbBinaryCompare)
If lngPos > 0 Then
vntTo = Mid(vntTo, lngPos + 1)
End If
wkbOpen.Worksheets(ComboBox1.Value).Range(vntCopy).Copy _
Destination:=ThisWorkbook.Worksheets(ComboBox2.Text).Range(vntTo)
End If
End Sub
Private Sub CommandButton4_Click()
If Not wkbOpen Is Nothing Then
wkbOpen.Close
End If
Unload Me
End Sub
Private Sub RefEdit2_Enter()
If ComboBox2.ListIndex > -1 Then
RefEdit2.Value = ThisWorkbook.Worksheets(ComboBox2.Text) _
.Cells(1, 1).Address(External:=True)
End If
End Sub
Private Function GetReadFile(vntFileNames As Variant, _
Optional strFilePath As String, _
Optional blnMultiSel As Boolean = False, _
Optional strTitle As String) As Boolean
' FileDialog使用版
Dim i As Long
Dim objFDL As FileDialog
Dim vntSelected As Variant
Dim vntFilters As Variant
'Filterを指定
vntFilters = Array("Excel File", "*.xls;*.xlsx;*.xlsm")
'[ファイル参照] ダイアログの FileDialog オブジェクトを作成
Set objFDL = Application.FileDialog(msoFileDialogFilePicker)
'Show メソッドでダイアログを表示し、ユーザーのアクションを取得
With objFDL
'タイトルを設定
If strTitle <> "" Then
.Title = strTitle
End If
'初期フォルダ及び、指定ファイル名を設定
If strFilePath <> "" Then
.InitialFileName = strFilePath
End If
'Filterを設置
With .Filters
.Clear
For i = 0 To UBound(vntFilters) Step 2
.Add vntFilters(i), vntFilters(i + 1), i \ 2 + 1
Next i
End With
'表示するFilterを設定
.FilterIndex = 1
'MultiSelectを設定
.AllowMultiSelect = blnMultiSel
'ユーザーがボタンをクリック
If .Show = -1 Then
If blnMultiSel Then
'ファイル名保存する配列を確保
ReDim vntFileNames(1 To .SelectedItems.Count)
'FileDialogSelectedItemsコレクション内のすべてのファイル名を取得
i = 0
For Each vntSelected In .SelectedItems
'選択した各アイテムのパスを含む値を取得
i = i + 1
vntFileNames(i) = vntSelected
Next vntSelected
Else
vntFileNames = .SelectedItems(1)
End If
'戻り値としてTrueを返す
GetReadFile = True
End If
End With
Set objFDL = Nothing
End Function
|
|
Hirofumi
- 10/10/8(金) 20:16 -
