- 締切済み
ワードベーシックで、離れた二つの箇所の属性を取得する方法
Wendy02の回答
- Wendy02
- ベストアンサー率57% (3570/6232)
こんばんは。 こちらの思惑で作りました。本来は、アドインにして、コマンドボタンに付けるとは良いのですが、まだ、ベータです。蛍光ペンで一覧を作ります。新旧のリストになります。ブックマークで付けていきますから、完全に、旧リストの単語を削除してしまうと、ズレてしまうかもしれません。なお、蛍光ペンを拾うサンプル・マクロは出ていますが、誤動作するので、私のオリジナル・マクロです。 現在は、ブックマークの名称欄に、リンクを付けていません。 失敗したときのことを考えて、「初期化プログラム」を付けておきます。 '-------------------------------------------- 'Option Explicit Private Const LISTDOC As String = "CheckList1.doc" 'チェックリスト Private Const MYCOLOR As Integer = wdYellow '黄色--7 Sub WordHilightFind() Dim arList() As String Dim i As Long Dim j As Long Dim NewDoc As Document Dim v As Variant Dim boolFound As Boolean Dim intCount As Integer ReDim arList(0) arList(0) = "元リスト" & Format$(Date, "yy.mm.dd") i = 1 For Each v In ActiveDocument.Bookmarks If v.Name Like "t#" Then MsgBox "すでに、リストがあるはずですから、'SecountListUp'を実行してください。", vbInformation Exit Sub End If Next Selection.HomeKey Unit:=wdStory Options.DefaultHighlightColorIndex = MYCOLOR Selection.Find.ClearFormatting With Selection.Find .Highlight = True .Text = "*" .Forward = True .Format = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchFuzzy = False .MatchWildcards = True End With Application.ScreenUpdating = False Do With Selection.Find .Execute With Selection.Range n = .Start If b = 0 Then s = n b = n End If If n - b > 1 Then Selection.SetRange s, b + 1 SetBookMark Selection.Range, "t" & CStr(i) ReDim Preserve arList(i) arList(i) = Selection.Range.Text Selection.MoveRight Unit:=wdCharacter, Count:=Len(arList(i)) s = n i = i + 1 End If b = n End With End With boolFound = Selection.Find.Found Loop While boolFound = True Application.ScreenUpdating = True Selection.SetRange s, b + 1 SetBookMark Selection.Range, "t" & CStr(i) ReDim Preserve arList(i) arList(i) = Selection.Range.Text '-----------新しい表--------- Set NewDoc = Documents.Add AddmyTable NewDoc, UBound(arList()) + 1, 3 'リストの1行目使用 NewDoc.SaveAs LISTDOC With NewDoc For j = 1 To UBound(arList()) + 1 'リストの1行目使用 With .Tables(1) If j = 1 Then .Cell(j, 1).Range.Text = "ブックマーク" Else .Cell(j, 1).Range.Text = "t" & j - 1 End If .Cell(j, 2).Range.Text = arList(j - 1) End With Next End With End Sub Private Sub SetBookMark(rng As Range, ByVal tName As String) With ActiveDocument.Bookmarks .Add Range:=Selection.Range, Name:=tName .DefaultSorting = wdSortByName .ShowHidden = True End With End Sub Private Sub AddmyTable(mDoc As Document, ByVal rw As Integer, ByVal col As Integer) mDoc.Tables.Add _ Range:=Selection.Range, _ NumRows:=rw, _ NumColumns:=col, _ DefaultTableBehavior:=wdWord9TableBehavior, _ AutoFitBehavior:=wdAutoFitFixed End Sub '=================================================================================== Sub SecountListUp() '二度目のリストアップ Dim v As Variant Dim i As Long Dim myDoc As Document Dim lisDoc As Document On Error GoTo ErrHandler If ActiveDocument.Bookmarks.Count = 0 Then MsgBox "文章のあるドキュメントをアクティブにしてください。", vbCritical Exit Sub End If Set myDoc = ActiveDocument Set lisDoc = Documents(LISTDOC) With lisDoc.Tables(1) .Cell(1, 3).Range.Text = "新リスト" For i = 2 To myDoc.Bookmarks.Count + 1 .Cell(i, 3).Range.Text = myDoc.Bookmarks(i - 1).Range.Text Next End With lisDoc.Activate If i > 1 Then MsgBox "リストが更新されました。", vbInformation End If Exit Sub ErrHandler: If Dir(myDoc.Path & "\" & LISTDOC) <> "" Then Application.Documents.Open LISTDOC Resume End If End Sub '=================================================================================== Sub CleanUpBookNames() '初期化ブログラム(リストファイルも削除) Dim v As Variant Dim i As Integer Dim dum As Document On Error Resume Next Set dum = Documents(LISTDOC) dum.Close False On Error GoTo 0 If MsgBox("リストを初期化します。", vbQuestion + vbOKCancel) = vbCancel Then Exit Sub End If For Each v In ActiveDocument.Bookmarks If v.Name Like "t#*" Then v.Delete i = i + 1 End If Next v If i > 0 Then i = 1 Else i = 0 End If If Dir(ActiveDocument.Path & "\" & LISTDOC) <> "" Then If MsgBox("リストドキュメントを削除してよろしいですか", vbQuestion + vbOKCancel) = vbCancel Then Exit Sub End If Kill ActiveDocument.Path & "\" & LISTDOC i = i + 2 Else MsgBox "リストドキュメントファイルが見つかりません。手動で削除してください。", vbInformation End If If i = 3 Then MsgBox "すべて完了しました。", vbInformation ElseIf i = 2 Then MsgBox "リストファイルのみ削除しました。" & vbCrLf & LISTDOC, vbInformation ElseIf i = 1 Then MsgBox "ブックマークのみ削除しました。", vbInformation ElseIf i = 0 Then MsgBox "ブックマークもリストファイルの削除も実行されませんでした。", vbInformation End If End Sub
関連するQ&A
- ワードの詳しいスタイルを知らせるマクロ
ワード2007です。カーソルのおいてある段落のスタイルを知るマクロを作りました。 Sub スタイルを伝える() Dim 範囲 As Range Dim スタイル As Style Set 範囲 = Application.Selection.Range Set スタイル = 範囲.Paragraphs(1).Style MsgBox ("カーソルのあった場所のスタイルは " _ & vbCrLf & vbCrLf & スタイル) End Sub です。その段落が見出し2だったとします。全体ではなしに、二文字だけに、アンダーラインしたとします。スタイルウインドウを見ると、「見出し2+下線」と表示されています。 しかし、上のマクロでは、相変わらず、「見出し2」としかメッセージしてくれません。 「見出し2+下線」とメッセージさせることはできないでしょうか。
- ベストアンサー
- Word(ワード)
- ワードVBAで、段落のタブの数を数えたい。
ワード2002使用です。 2段落目に複数のタブが入力されています。 ワードVBAで、選択した段落のタブの個数を数えたい。 sub タブ() Dim tab数 As Integer ActiveDocument.Paragraphs(2).Range.Select tab数 = Selection.Paragraphs.tabs.Count←ここがよくわかりません msgbox tab数 end sub よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- midステートメント セルを指定したい
エクセルなのですが、 Sub N文字目を置換する1() Dim N As Long Range("a1").Value = "abcde" N = 2 '置換する文字の位置 ’start(省略不可) Mid(Range("a1").Value, N) = "X" MsgBox Range("a1").Value End Sub このように、セルを指定することはできないのでしょうか? このコードを実行しようとすると、 Mid(Range("a1").Value, N) = "X"の部分で「変数が必要です」とコンパイルエラーになります。 Sub N文字目を置換する2() Dim moji As String Dim N As Long Range("a1").Value = "abcde" moji = Range("a1").Value N = 2 Mid(moji, N) = "X" MsgBox moji End Sub このように、セルの値を一度変数に入れると問題なく実行できますが、 なぜダイレクトにmidステートメントでセルを指定できないのかわからないので教えてください。 よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- 【Excelマクロ】 セルの色取得
古いファイルを加工することが多々あり、セルに塗られている色を調べる(セルの書式設定→塗りつぶし→その他の色→ユーザー設定)のが非常に面倒です。 RGB値をマクロで表示させる方法を見つけたものの、セルが指定(A1/A2/B1)されています。 <1つ右> Sub 色情報取得() Dim r As Long Dim g As Long Dim b As Long n = Range("A1").Interior.Color r = n \ 256 ^ 0 Mod 256 g = n \ 256 ^ 1 Mod 256 b = n \ 256 ^ 2 Mod 256 Range("A2") = r & "," & g & "," & b End Sub <1つ左> Sub 色情報取得() Dim r As Long Dim g As Long Dim b As Long n = Range("A1").Interior.Color r = n \ 256 ^ 0 Mod 256 g = n \ 256 ^ 1 Mod 256 b = n \ 256 ^ 2 Mod 256 Range("B1") = r & "," & g & "," & b End Sub 調べたいセルにカーソルを置いた状態で実行するマクロをご教示ください。 希望1.画像のように1つ右 or 1つ左、もしくはn個右 or n個下など、表示させたいセルを自由に設定したい 希望2.複数セルを一括で処理したい よろしくお願い致します。
- ベストアンサー
- Excel(エクセル)
- VBA 選択された離れたセルの値の取得について
EXCELのVBAでどうしても前に進めず困っております。 目的としているコードは、離れたセル(複数)をあらかじめCtrlキーで選択状態にしておき、選択されたセルの値のみをVBAが別のセルに並べていくというものです。 以下が私の作ったコードなのですが、思ったとおりの動作をしてくれません。 VBA初心者なもので、おかしな記述がたくさんあると思うのですが、どなたかアドバイスお願いします。 Public Sub xx() Dim SelectArea As String Dim TargetCell As Range Dim a As Integer Dim Row As Integer Dim Column As Integer Dim CNT1 As Integer a = 0 Row = 0 Column = 0 For CNT1 = 1 To 10 Row = Row + 1 SelectArea = Selection.Address Set TargetCell = Range("B3").Cells(Row - 1, Column) If Intersect(Range(SelectArea), TargetCell) Is Nothing Then Else Range("A30").Cells(a, 0) = Range("B3").Cells(Row - 1, Column).Value a = a + 1 End If Next End Sub
- ベストアンサー
- オフィス系ソフト
- ExcelVBAのRangeで複数指定
Excel 2003 のVBAで質問です。 以下のサンプルプログラムですが、最後の MsgBox で 1 になってしまいます。 3 が帰ってくるようにするには、Range でどのように指定すればよいのでしょうか。 宜しくお願いします。 〔Sheetの値〕 ┌─┬─┬─┬─┐ │*│A│B│C│ ├─┼─┼─┼─┤ │1│11│12│13│ ├─┼─┼─┼─┤ │2│21│22│23│ ├─┼─┼─┼─┤ │3│31│32│33│ ├─┼─┼─┼─┤ │4│41│42│43│ ├─┼─┼─┼─┤ │5│51│52│53│ └─┴─┴─┴─┘ 〔サンプルプログラム〕 Dim myArray1, myArray2 As Variant myArray1 = ThisWorkbook.ActiveSheet.Range("A1:C5") myArray2 = ThisWorkbook.ActiveSheet.Range("A1:A5,B1:B5,C1:C5") '指定が間違ってる? MsgBox UBound(myArray1, 1) '結果 5 MsgBox UBound(myArray1, 2) '結果 3 MsgBox UBound(myArray2, 1) '結果 5 MsgBox UBound(myArray2, 2) '結果 1 → 3になって欲しい
- 締切済み
- Visual Basic
- ExcelVBA 挿入貼り付けについて
ExcelVBA勉強中の者です 変数にA1セルを指定し、別のセルへA1の値を挿入したいのですが上手くいきません。 Dim A1Cell As Range Set A1Cell = Range("A1") ↑Msgbox(A1Cell)にてA1セルの値を出力したので変数の宣言は出来ていると思います。 ActiveCell.Resize(1, 5).Select Selection.Copy Range(A1Cell).Selection.Insert Shift:=xlDown ↑ここでの変数の指定が間違っていると思われます Application.CutCopyMode = False かなり調べたつもりですが、自力では解決できずどなたか御助力お願い致します。
- ベストアンサー
- オフィス系ソフト
- 実行時エラー1004 オートフィルができない
エクセルなのですが、A列の文字にたいする数式をB列に入れて最終行までオートフィルするマクロを作りたいのですが実行時エラー1004が発生してしまいます。 Sub macro1() Dim LastRow As Long LastRow = Range("A65536").End(xlUp).Row Range("B1").Value = "=LEN(A1)" Range(Range("B1"), Selection).AutoFill Destination:=Range("B1:B" & LastRow) End Sub このコードです。 Range(Range("B1"), Selection). ここら辺が怪しいかなと思ってるのですが、どうすればいいでしょうか? オートフィルを使わずにfor~nextでやる方法も知ってますが、オートフィルでやる方法をご教授いただきたいです。 よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- 【VBA】コピー&複数個所のペースト繰り返し
下記のように、1つの値をコピーし、別シートの複数個所(同じ列の違う行)へ順次ペーストしたいのですが、貼付けデータやペースト箇所が増えた場合でも対応できるようなVBAを教えてください。 よろしくおねがいいたします。 ========================================================= Sub コピペ() '←1人目をコピー Worksheets("“コピー元シート”").Range("B7").Select Selection.Copy '←貼付け Worksheets(“貼付シート”).Range("B9", "B37", "B65", "B93", "B121", "B149", "B177").Select Selection.PasteSpecial Paste:=xlPasteFormulas '←2人目をコピー Worksheets("“コピー元シート”").Range("B8").Select Selection.Copy '←貼付け Worksheets(“貼付シート”).Range("B11", "B39", "B67", "B95", "B123", "B151", "B179").Select Selection.PasteSpecial Paste:=xlPasteFormulas '←3個の値をコピー Worksheets("“コピー元シート”").Range("B9").Select Selection.Copy '←貼付け Worksheets(“貼付シート”).Range("B13", "B41", "B69", "B97", "B125", "B153", "B181").Select Selection.PasteSpecial Paste:=xlPasteFormulas '←4個の値をコピー Worksheets("“コピー元シート”").Range("B10").Select Selection.Copy '←貼付け Worksheets(“貼付シート”).Range("B15", "B43", "B71", "B99", "B127", "B155", "B183").Select Selection.PasteSpecial Paste:=xlPasteFormulas '←5個の値をコピー Worksheets("“コピー元シート”").Range("B11").Select Selection.Copy '←貼付け Worksheets(“貼付シート”).Range("B17", "B45", "B73", "B101", "B129", "B157", "B185").Select Selection.PasteSpecial Paste:=xlPasteFormulas End Sub
- ベストアンサー
- Excel(エクセル)
- checkboxの値の取得方法
教えてください (excel2010) checkboxをセルRange("C1")から下方に10個作成しています。(下方を参照) 質問は2点あります。 [質問1] 10個のセルにcheckboxは作成されるのですが、この後、これらに設定したセルの値(Check on/off)を判定するには、どのようコーディングすればよいのでしょうか? [質問2] 10個のセル作成時、当初 ".LinkedCell=" で指定したセルに「True/False」が表示されていましたが、現在以下の処理を行っても「True/False」が表示されません。 確認事項や対処方法にお心あたりがあれば、ご教授願います。 '------------------------------------------ checkbox 10個作成 Dim myChk As Object Dim i As Long Dim 個数 As Long Dim 開始セル As Range 個数 = 10 'チェックボックス作成数 Set 開始セル = Range("C1") 'チェックボックス作成の開始セル位置 For i = 0 To 個数 - 1 With StartCell.Offset(i) Set myChk = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", Link:=False, _ DisplayAsIcon:=False, _ Left:=.Left, Top:=.Top, _ Width:=.Width, Height:=.Height) End With With myChk .LinkedCell = 開始セル.Offset(i, 1).Address .Object.Caption = "" .Object.Value = False End With Next
- ベストアンサー
- Excel(エクセル)
補足
Wendy02 様 いろいろご努力いただき、ありがとうございます。 会社のパソコンでないとできませんので、月曜日に試してみます。