まだVBAに慣れていませんが、下記のソースを書いてみました。
★印の間の部分の処理を、最初はFor Nextで書いていたのですが、理由が解らないですが…うまく処理されない為、タイトルの2種類（セルのFindメソッドとMatch関数)を使って処理しようと思い書き直したのですがうまく処理されません。
どこがいけないのか解らず数時間も悩んでしまいました。
すみませんが、どなたか教えてください。よろしくお願いします。
Sub 外注別案内書作成()
Dim ws As Worksheet 'オブジェクト格納
Dim i As Long, j As Long '繰り返す回数格納
Dim annaicode As Variant '案内場所C格納
Dim addwsname As Variant 'シート名前格納(※案内場所名)
Dim flag As Boolean '真偽
Dim r As Range 'Findメソッドの返り値格納
Dim K As Long 'Match関数の返り値格納
'レポート元でQ列の情報が入っている時に、案内場所別で情報を作成する。
'レポート元でQ列に値がある時に、annaicode変数へ格納。
For i = 2 To Worksheets("レポート元").Cells(Rows.Count, "A").End(xlUp).Row
If Cells(i, "Q").Value <> "" Then
annaicode = Cells(i, "Q").Value
End If
★ココから--------
'外注一覧でannai変数と一致した時に、addwsname変数へ格納。 FindメソッドとMatch関数
With Worksheets("外注一覧").Columns("1:1")
Set r = .Find(What:=annaicode, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
If r Is Nothing Then
MsgBox i & "行目の案内場所Cの入力が不正です。" & vbCrLf & "処理を中断しますね", _
vbOKOnly + vbExclamation, "お知らせ"
Else
With Worksheets("外注一覧")
K = .Match(annaicode, .Range(.Cells(1, "A").Value, .Cells(.Rows.Count, "A").Value), 0)
addwsname = .Cells(K, "B").Value + "_案内"
End With
End If
End With
★ココまで--------
'ワークシートコレクション内でaddwsname変数と一致した時に、flag変数をTrueにする。
For Each ws In Worksheets
If ws.Name = addwsname Then
flag = True
End If
Next ws
'flag変数の値により、各々処理をする。
If flag = True Then
Worksheets("レポート元").Cells(i, "A").EntireRow.Copy _
Destination:=Worksheets(addwsname).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
flag = False
Else
Worksheets.Add
ActiveSheet.Name = addwsname
Worksheets("レポート元").Cells(i, "A").EntireRow.Copy _
Destination:=Worksheets(addwsname).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next i
End Sub
まだVBAに慣れていませんが、下記のソースを書いてみました。
★印の間の部分の処理を、最初はFor Nextで書いていたのですが、理由が解らないですが…うまく処理されない為、タイトルの2種類（セルのFindメソッドとMatch関数)を使って処理しようと思い書き直したのですがうまく処理されません。
どこがいけないのか解らず数時間も悩んでしまいました。
すみませんが、どなたか教えてください。よろしくお願いします。
Sub 外注別案内書作成()
Dim ws As Worksheet 'オブジェクト格納
Dim i As Long, j As Long '繰り返す回数格納
Dim annaicode As Variant '案内場所C格納
Dim addwsname As Variant 'シート名前格納(※案内場所名)
Dim flag As Boolean '真偽
Dim r As Range 'Findメソッドの返り値格納
Dim K As Long 'Match関数の返り値格納
'レポート元でQ列の情報が入っている時に、案内場所別で情報を作成する。
'レポート元でQ列に値がある時に、annaicode変数へ格納。
For i = 2 To Worksheets("レポート元").Cells(Rows.Count, "A").End(xlUp).Row
If Cells(i, "Q").Value <> "" Then
annaicode = Cells(i, "Q").Value
End If
★ココから--------
'外注一覧でannai変数と一致した時に、addwsname変数へ格納。 FindメソッドとMatch関数
With Worksheets("外注一覧").Columns("1:1")
Set r = .Find(What:=annaicode, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
If r Is Nothing Then
MsgBox i & "行目の案内場所Cの入力が不正です。" & vbCrLf & "処理を中断しますね", _
vbOKOnly + vbExclamation, "お知らせ"
Else
With Worksheets("外注一覧")
K = .Match(annaicode, .Range(.Cells(1, "A").Value, .Cells(.Rows.Count, "A").Value), 0)
addwsname = .Cells(K, "B").Value + "_案内"
End With
End If
End With
★ココまで--------
'ワークシートコレクション内でaddwsname変数と一致した時に、flag変数をTrueにする。
For Each ws In Worksheets
If ws.Name = addwsname Then
flag = True
End If
Next ws
'flag変数の値により、各々処理をする。
If flag = True Then
Worksheets("レポート元").Cells(i, "A").EntireRow.Copy _
Destination:=Worksheets(addwsname).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
flag = False
Else
Worksheets.Add
ActiveSheet.Name = addwsname
Worksheets("レポート元").Cells(i, "A").EntireRow.Copy _
Destination:=Worksheets(addwsname).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next i
End Sub
特定のセルに数字を入力することでＶＬＯＯＫＵＰで印刷ページを
検索して指定できるシートを作成しています。
下記のようなＶＢＡを作成しました。
印刷開始ページと印刷終了ページを指定する場合、
セルの指定はどのようにすれば、よいのでしょうか？
開始ページと終了ページが同じセルの為、
開始ページ＝Rnage("セル")
終了ページ＝Rnage("セル")
としてしまいますと、エラーが出てしまいます。
Sub 印刷()
Dim S As Long
Dim B As Long
S = Application.InputBox("印刷開始ページを入力", Type:=1)
If 開始ページ = 0 Then Exit Sub
B = Application.InputBox("印刷終了ページを入力", Type:=1)
If 終了ページ = 0 Then Exit Sub
ActiveSheet.PageSetup.Order = xlOverThenDown
ActiveWindow.SelectedSheets.PrintOut _
From:=S, To:=B, Collate:=True
End Sub
宜しくお願い致します。
xabcxdefgxhijk・・・ のように並んだ文字列を
xabc(改ページ)
xdefg(改ページ)
xhijk・・・
のように，xの位置で自動的に改ページしたい。
------------------------------------------
上記の動作を実行するためのマクロを見よう見まねで
以下に示すように作成したのですが，成功したり成功しなかったりします。
原因が分かる方ご指摘ご修正いただけるとありがたいです。
（Wordのマクロは今回始めて作成する全くの初心者です。）
WordのバージョンはOffice2003です。
よろしくお願いいたします。
------------------------------------------
Sub kaipage()
Dim blnFound As Boolean
Dim rngContent As Range
Dim intCount As Integer
blnFound = True
Set rngContent = ActiveDocument.Content
intCount = 0
Do While blnFound = True
With rngContent.Find
.ClearFormatting
.Wrap = wdFindContinue
.Text = "x"
.Replacement.Text = "$"
.Execute Replace:=wdReplaceOne, Forward:=True
End With
Selection.Find.Execute
Selection.InsertBreak Type:=wdPageBreak
blnFound = rngContent.Find.Found
If blnFound = True Then intCount = intCount + 1
Loop
MsgBox (intCount & "個見つかりました。")
End Sub
Excel VBAについて確認させてください。
下記のExcelマクロはエクセルのA列に入力されてある文字を順に読み込んで
ユーザが入力したテキストファイル（＝FN1）を読み込んで
エクセルのA列に入力されてある文字が見つかった場合は削除する動作の繰り返し作業を行い、
エクセルのA列の文字が入力されてある最後の行まで行ったら
出力ファイル（＝FN2）として保存するプログラムです。
ここで出力ファイルにはエクセルのA列に入力されていない文字が
残るものと思われますが、ここで入力されていない文字で
重複する文字があった場合はまとめて一つにする方法をを
ご教授いただけますでしょうか。
以上お手数おかけしますがよろしくお願いします。
以下、プログラム本文です。
-----------------------------------------------
Sub sample()
Dim a As String
Dim y As Long
Dim x As String
Dim FN1 As String
Dim FN2 As String
x = InputBox("チェックするファイル名を入力してください。（拡張子も含めてください。）")
FN1 = ThisWorkbook.Path & "\" & x
FN2 = ThisWorkbook.Path & "\チェック済" & x
With CreateObject("Scripting.FileSystemObject").GetFile(FN1).OpenAsTextStream
a = .ReadAll
For y = 1 To Cells(Rows.Count, 1).End(xlUp).Row
a = Replace(a, Cells(y, 1), "") '読み込んだテキストファイルにエクセルのA列にある文字が見つかった場合削除
a = Replace(a, vbCrLf, "") '改行コードの削除
a = Replace(a, vbTab, "") 'タブコードの削除
Next
.Close
End With
With CreateObject("Scripting.FileSystemObject").OpenTextfile(FN2, 2, True)
.Write a
.Close
End With
End Sub
現在開いているpptと同フォルダ内の全てのpptファイルに対して、
1ページ目のサブタイトルに日付を一括で入れるマクロを作成したいのです。
下記のように作成してみたのですが、いちおう全ファイルに希望通りの個所に希望の文字列が入るのですが、実行にものすごく時間がかかりました。。
ステップインで確認すると、"Presentations.Open FileName:="の行で、Forループの繰り返し毎に、全ファイル開いてしまっているようで。。
一般の初心者で、見よう見まねでやっていまして、ヘルプやWeb検索でも、どうしても解決策を見いだせませんでした。
どなたか、ご教示いただけませんでしょうか。
よろしくお願いいたします。_(_ _)_
------------------------------------------------------------
Sub AddDatetoAllPPT()
Dim todaydate As String
todaydate = Year(Now) & "年" & Month(Now) & "月" & Day(Now) & "日"
Dim myShape As Shape
Dim FSO As Object, Files As Variant
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Files = FSO.GetFolder(ActivePresentation.Path).Files
For Each File In FSO.GetFolder(ActivePresentation.Path).Files
Presentations.Open FileName:=ActivePresentation.Path & "\" & File.Name
Set myShape = ActivePresentation.Slides(1).Shapes("サブタイトル 2")
myShape.TextFrame.TextRange.Text = todaydate
ActivePresentation.Saved = True
Next
End Sub
ワークシート上にOLEオブジェクトのオプションボタンを設置するため、以下のようなマクロを書きました。
意図したように作動するのですが、一箇所だけ不具合があります。
.Object.BackStyle = fmBackStyleTransparent と、透過に設定してるのですが透過してくれません。（エラーにもなりません。）
どこがおかしいのでしょうか？
Sub test02()
Dim n As Long, i As Long
Dim myRng As Range
With ActiveSheet
For n = 3 To 5
For i = 3 To 10
Set myRng = .Cells(i, n)
Set opt = .OLEObjects.Add(ClassType:="Forms.OptionButton.1", _
Left:=myRng.Left + 2, Top:=myRng.Top + 2, Width:=myRng.Width * 0.8, Height:=myRng.Height * 0.9)
opt.LinkedCell = myRng.Offset(, 4).Address
opt.Object.Value = False
opt.Object.GroupName = "OptG" & i
opt.Object.Caption = Choose(n - 2, "Yes", "No", "N/A")
opt.Object.BackStyle = fmBackStyleTransparent
Next i
Next n
End With
End Sub
