[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ﾏｸﾛで条件分岐でシートを指定』（忘却者）
いつもお世話になります。
どうしても思い出せないのでどなたかご教示下さい。
【処理内容】
マクロで使用するシートを指定（同じBook内です。）してから
次の処理に進みたいのですが、
どのようにすればよろしいでしょうか。
あまりにもひどい状態で申し訳ございません。
Dim ans As Integer Dim sht As Worksheet
ans = MsgBox("今回のリストは月単位ですか？", vbQuestion + vbYesNo)
If ans = vbOK Then
sht("月").Select
Else
sht("週").Select
End If
Set sht = ThisWorkbook.Sheets("ans") ※指定できずﾏｸﾛが停まります。
大変お手数をお掛けいたしますがよろしくお願いいたします。
＜ 使用 Excel：Excel2013、使用 OS：Windows7 ＞
こうか？
Dim ans As Integer
Dim sht As Worksheet
ans = MsgBox("今回のリストは月単位ですか？", vbQuestion + vbYesNo)
If ans = vbYes Then
Set sht = Worksheets("月")
Else
Set sht = Worksheets("週")
End If
vbYesNoの場合、返値はvbYesかvbNo
（ねむねむ） 2015/11/25(水) 16:38
コメント頂きまして有難うございます。
YesがOkになっていることに気がつきませんでした。
おかげ様で処理ができました。
関連してご教示頂きたいのですが、
条件分岐で選択されたシートを指定するにはどのようにすればよろしいでしょうか。
以前は、
Set sht = ThisWorkbook.Sheets("変更前のシート")で処理をしていました。
大変お手数をお掛けいたしますが
よろしくお願いいたします。
（忘却者） 2015/11/25(水) 17:09
Dim ans As Integer
Dim sht As Worksheet
ans = MsgBox("今回のリストは月単位ですか？", vbQuestion + vbYesNo)
If ans = vbYes Then
Set sht = Worksheets("月")
Else
Set sht = Worksheets("週")
End If
これで「はい」を選択した場合にshtで「月」シートを、「いいえ」でshtで「週」シートにアクセスできるようになっているが 実際に行いたいのはどのようなことか？ （ねむねむ） 2015/11/25(水) 17:13
早速コメント頂きまして有難うございます。
シートを指定した後に、呼び出した別ファイルから担当者別にデータを貼り付けた後、
指定したフォルダに保存する処理を考えております。
（忘却者） 2015/11/25(水) 17:30
もう一つWorksheetの変数を用意してそちらにセットでいいのでは？
（ねむねむ） 2015/11/26(木) 09:14
コメント頂きまして有難うございます。
ご提案の方法を試してみたのですが、
マクロが停まりました。。。
原因と思われる箇所はこちらかと思われます。
下の○○の部分に条件分岐で選択した変数を入力すればよろしいかご教示下さい。
Set sht = ThisWorkbook.Sheets("○○")←Sheet名を指定しないので、マクロが停まるようです。
念のためコードの全体を掲載いたします。
（処理の流れ）
１ データ基のファイルを選択
２ 作成ファイルの保存先
３ （同じBook内の）貼付先Sheetの指定（条件分岐）
４ ３のSheet内の日付入力（２種類）
５ データ基ファイルより担当者別に分ける
６ 貼付先に貼り付ける
７ ファイルを保存する
８ データ基がなくなるまで繰り返す
９ 完了
Sub ファイル作成()
Dim z As Long
Dim x As Long
Dim ans As Integer
Dim 連絡日 As Date
Dim 年度 As String
Dim sht As Worksheet
Dim sht2 As Worksheet
Dim c As Range
Dim tSh As Worksheet
Dim fList As Range
Dim i As Long
Dim svPath As String
Dim fName As String
Dim ff As Variant
Dim fd As Object
Dim Shell As Object, myPath As Object
Dim hWnd As Long
Dim r As Range
Dim nBK As Workbook
Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可
Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示
'ブックの選択
ff = Application.GetOpenFilename("Ｅｘｃｅｌブック,*.xls*", , "ファイルを選択してください")
If ff = False Then Exit Sub 'キャンセルボタン
'保存フォルダの選択
hWnd = Application.hWnd
Set Shell = CreateObject("Shell.Application")
Set fd = Shell.BrowseForFolder(hWnd, "保存フォルダを選んでください", _
BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX)
If fd Is Nothing Then Exit Sub 'キャンセルボタン
svPath = fd.Items.Item.Path & "\"
'連絡Sheetの選択
ans = MsgBox("今回のリストは月単位ですか？", vbQuestion + vbYesNo)
If ans = vbYes Then
Set sht2 = Worksheets("月")
連絡日 = Application.InputBox("「メール送信予定日」を入力してください" & vbLf & "例：2015/12/9", "", Date)
Range("C4") = 連絡日
年度 = Application.InputBox("「年」を入力してください" & vbLf & "例：2015年", "", "2015年")
Range("C7") = 年
Else
Set sht2 = Worksheets("週")
連絡日 = Application.InputBox("「メール送信予定日」を入力してください" & vbLf & "例：2015/12/9", Type:=1)
Range("C4").Value = 連絡日
年度 = Application.InputBox("「年度」を入力してください", "", "2015")
Range("C7") = 年度
End If
Set wb = Workbooks.Open(ff) 'ファイルを作成する基データを開く
Set shm = wb.Sheets("連絡用")
Set sht2 = ThisWorkbook.Sheets ← ※ここでマクロが停まります。。。
Set sht = ThisWorkbook.Sheets
Application.ScreenUpdating = False
z = shm.Cells(1, Columns.Count).End(xlToLeft).Column
x = shm.Range("A" & Rows.Count).End(xlUp).Row - 1
shm.Columns("D").Copy shm.Cells(1, z + 2)
shm.Columns(z + 2).RemoveDuplicates Columns:=1, Header:=xlYes
shm.Cells(1, z + 4).Value = shm.Range("D1").Value
shm.Cells(1, z + 6).Resize(, 5).Value = shm.Range("A1:E1").Value
For Each c In shm.Cells(1, z + 2).CurrentRegion
If c.Row > 1 Then
shm.Cells(2, z + 4).Value = c.Value
shm.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=shm.Cells(1, z + 4).Resize(2), CopyToRange:=shm.Cells(1, z + 6).Resize(, 5), Unique:=False
With shm.Cells(1, z + 6).CurrentRegion.Resize(, 3)
sht.Range("C14:E43").ClearContents
Intersect(.Cells, .Cells.Offset(1)).Copy sht.Range("C14")
End With
sht.Range("C2").Value = shm.Cells(3, z + 10).Value
sht.Range("C13").CurrentRegion.Borders.LineStyle = xlContinuous
sht.Copy
Set nBK = ActiveWorkbook
With nBK.Sheets(1)
On Error Resume Next
Set r = .Range("C12:C43").SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not r Is Nothing Then r.EntireRow.Delete
End With
Range("A1").Select
'作成したファイルを保存し、閉じる
fName = shm.Range("N2").Value & "_" & shm.Range("O2").Value & ".xlsx"
Application.DisplayAlerts = False
With ActiveWorkbook
.SaveAs svPath & fName
.Close
End With
End If
Next
'元の状態に戻す
shm.Cells(1, z + 2).CurrentRegion.Clear
shm.Cells(1, z + 4).CurrentRegion.Clear
shm.Cells(1, z + 6).CurrentRegion.Clear
sht.Range("C2").Clear
sht.Range("C14:E43").Clear
Range("A1").Select
shm.Parent.Close False
Application.ScreenUpdating = True
MsgBox "完了しました。"
End Sub
よろしくお願いいたします。
（忘却者） 2015/11/26(木) 11:35
判断部分で代入しているのでそのあとにまた代入しなおす必要はないはずだが？
VBAからすると
>Set sht2 = Worksheets("月")
>Set sht2 = Worksheets("週")
は
>Set sht2 = ThisWorkbook.Worksheets("月")
>Set sht2 = ThisWorkbook.Worksheets("週")
なのかもしれないが。
(きちんとVBAを追っていないのでそこの判断はそちらでしてくれ)
（ねむねむ） 2015/11/26(木) 11:46
度々ご教示頂きまして有難うございます。
代入しなおしているコードを消してみたところ、
マクロが途中で停まることなく作動しました。
有難うございました。
大変助かりました。
（忘却者） 2015/11/26(木) 13:54
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.