匿名質問者
匿名質問者匿名質問者とは「匿名質問」を利用して質問した質問者。
「匿名質問」では、ユーザー名を公開せずに匿名の質問ができます。
詳しくはこちら

Excel VBAについて質問します。


エクセルで日記のようなものをつけていたのですがその内容をブログにアップしようと思っています。
そこで赤字や太字をフォントで囲んでくれるマクロを使用したいのですがどのように手をつけていいかわかりません。
例えば
今日はいい天気ですね。
の天気のみが赤字だとすると
今日はいい<font color="red">天気</font>ですね。
と変換出来たらと思っています。
また、太字も同様で
明日は雨らしいですよ。
の雨のみが太字の場合は
明日は<b>雨</b>らしいですよ。
というようにできたら幸いです。
また、その際にひとつのセルに複数の赤文字がある場合、例えば
今日はいい天気ですが明日は雨らしいですよ。
の天気と雨が赤文字の場合は
今日はいい<font color="red">天気</font>ですが明日は<font color="red">雨</font>らしいですよ。
というようにしたいのですがそれも可能でしょうか?太字も同様です。
わかりにくい説明になったかもしれませんが是非お力添えしていただけたら大変助かります。
どうかよろしくお願いします。

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2018/12/17 12:18:41
  • 終了:2018/12/24 12:20:04

回答(3件)

匿名回答1号 No.1

匿名回答1号「匿名質問」を利用した質問に回答すると「匿名回答○号」と匿名で表示されます。
「匿名質問」では、ユーザー名を公開せずに匿名の質問ができます。
詳しくはこちら
2018/12/17 15:12:04

VBAを作成してみました。
ただ、起動方式や変換内容の設定方法とかわからないので、勝手に考えています。
対象域は現在表示(アクティブ)のワークシート全域とし、
変換対象文字列と変換先文字列の設定は、ソース内の頭の方で設定しています。
仮に例のある「雨」と「天気」について定義しています。
これを適宜設定変更すれば良いです。
(おまけで逆変換も可能としてみました。つまり元に戻せる)

※以下をVBエディターの標準モジュールに貼り付けして試してみてください。


Option Explicit

Sub my文字列をタグ形式へ変換()
' 文字列変換
' 変換方向指定可能
' 変換文字列は配列に準備
'
'1.変換対象とするセル範囲を指定する
Dim trgRange As Range
Set trgRange = ActiveSheet.Cells ' 表示中のワークシートの全域とする

'2.変換文字列を準備する
Dim tbTrgStr(10)
Dim tbChgStr(10)
Dim wkTbStrSu
Dim wkI
wkI = 0

'=== 変換テーブル内容の設定 ==============
wkI = wkI + 1: tbTrgStr(wkI) = "天気": tbChgStr(wkI) = "<font color=""red"">天気</font>"
wkI = wkI + 1: tbTrgStr(wkI) = "雨": tbChgStr(wkI) = "<b>雨</b>"
' ~(このような形で、必要なだけ定義する)
' ※但し、配列数10をオーバーするようなら、機能見直し要!
' 配列数を拡張(ReDimを活用すれば尚よし)
'=========================================

wkTbStrSu = wkI ' 配列の有効数をセット

'3.実行可否を確認問い合わせする
Dim wkRes
wkRes = MsgBox("特定文字のタグ修飾変換処理を行います。" & vbCrLf _
& "対象範囲 " & trgRange.Address & vbCrLf _
& "変換文字列セット数:" & wkTbStrSu & vbCrLf _
& "よろしいですか?" & vbCrLf, vbOKCancel)
If wkRes <> vbOK Then
MsgBox "処理中止!"
End
End If

'4.変換方向を確認問い合わせする
Dim wkChgDir
wkRes = MsgBox("変換の方向の確認。" & vbCrLf _
& "通常方向(タグ形式への変換)で良いですか? " & vbCrLf _
& "(逆変換なら「いいえ」で応答)" & vbCrLf _
, vbYesNoCancel)
If wkRes = vbYes Then
wkChgDir = "順方向"
ElseIf wkRes = vbNo Then
wkChgDir = "逆方向"
Else
MsgBox "処理中止!"
End
End If


'5.変換処理を行う
For wkI = 1 To wkTbStrSu
If wkChgDir = "順方向" Then
trgRange.Replace What:=tbTrgStr(wkI), Replacement:=tbChgStr(wkI)
Else
trgRange.Replace What:=tbChgStr(wkI), Replacement:=tbTrgStr(wkI)
End If
Next wkI

'6.終了
MsgBox "終了しました!"

End Sub

匿名回答1号

まずお詫び申し上げます。
何やら自分でも合点のいかないままに安易に回答してしまいました。
他の回答を見て気付いた次第で、どうも、質問者様の意図を理解しないままの回答となりまして誠に失礼をいたしました。

で、改めまして、構成してみました。
ご確認いただければ幸いです。

ただ、今回のソースはいささかも結構大きいものとなっており、
またソースにHTMLタグを含んでをはてなのホームページ上に通常表示するには
表現上の加工が必要となることもあるので、別途にて示すことにします。
お手数ですが、以下のリンクより参照、ダウンロードして参考にでもして頂ければと思います。

参照先リンク
==============
https://drive.google.com/open?id=16gHjM4xn4hussflnoadXotQiFi9ugBUC
==============



主な補足、留意点
・処理対象範囲
 起動時に選択されているセルの全部に対して処理が行われる。

・1セル中に文字修飾を複数も可能
 赤色修飾およびボールド修飾は1セル中に複数存在も対応可能
(ただし、これらの領域の重なりについては対応できない)

・Excel上の文字修飾の復元
 タグ追加変換後にはそれまでの赤色やボールドの修飾(Excel上での)が消されてしまうので、
今回、これを復元するようにしている。
(ただし、セル内文字全体で文字修飾されているセルでは、変換後もこの修飾が解除されないため、変換後もセル全体が修飾の状態となる)
 ⇒この結果、付加したタブ文字にも同じ属性が適応されてしまい、都度タグ付加され多重してしまう。(他と不整合)
  ⇒でも、これを処理で回避を実現できた

・戻し機能を設けたいところだったが、・・・
 (また別途考えたい)

・文字色は赤だけを対象
処理で使用するColor値をRGBのhex形式で扱うように構成すればいろいろ可能と考えている。

(以上)

2018/12/19 17:41:21
匿名回答1号

再度の投稿となります。
今度は、変換の戻しの機能も追加してみました。
あくまでも文字の赤色と太字表示に限定してのものですが。
重複実行による多重変換を防ぐ機能も持っています。

起動方法も含め、確認と利用をしやすくするために、
Excelブックのままでアップしました。
(Excel2016マクロ形式ブックです。)
『赤字や太字をHtmlTag化するマクロ.xlsm』

以下から、慎重にダウンロードしてご確認ください。

参照先リンク
==============
https://drive.google.com/open?id=1o4x-bT_pUnY_cTAcb3ffmebN6vJZnM1v
==============

≪補足≫
Excelマクロ起動のショートカットも設定済みです。
確認テスト用ボタンにもコメント表示しているが、
Ctrl+Shift+G ⇒ 『Tag変換実行』を起動
Ctrl+Shift+B ⇒ 『Tag変換戻し』を起動

※このブックを開いておけば、このブック内だけでなく、
他のブックでも対象セルを選択して、このショートカットキーを
押せば処理を実行することができる。

(以上)

2018/12/20 18:10:06
匿名回答2号 No.2

匿名回答2号「匿名質問」を利用した質問に回答すると「匿名回答○号」と匿名で表示されます。
「匿名質問」では、ユーザー名を公開せずに匿名の質問ができます。
詳しくはこちら
2018/12/17 18:34:22

コードが汚いですがとりあえず動きます、、。

変換したいセルを選択して、HTML_Changeを動かしてください。

Dim Red As String
Dim Green As String
Dim Blue As String
Dim cRange As Range
Dim moji As String
Dim moji2 As String

Sub HTML_Change()
    For Each cRange In Selection
    moji = ""
    y = 1
        For i = 1 To Len(cRange)
            If cRange.Characters(Start:=i, Length:=1).Font.Color <> RGB(0, 0, 0) Then
                moji2 = BoldCHK(y, i - 1)
                moji = moji & moji2
                iLen = 1
                Do Until cRange.Characters(Start:=i, Length:=1).Font.Color <> cRange.Characters(Start:=i + iLen, Length:=1).Font.Color
                    iLen = iLen + 1
                Loop
                Call GetRGBValue(cRange.Characters(Start:=i, Length:=1).Font.Color, Red, Green, Blue)
                moji = moji & "<font color=""#" & Red & Green & Blue & """>"
                moji2 = BoldCHK(i, i + iLen - 1)
                moji = moji & moji2
                moji = moji & "</font>"
                i = i + iLen - 1
                y = i + 1
            End If
        Next
        If i <> y Then
            moji2 = BoldCHK(y, i - 1)
            moji = moji & moji2
        End If
    cRange.Value = moji
    Next cRange
End Sub

Function BoldCHK(st, en) As String
    BoldCHK = ""
    chky = st
    For chk = st To en
        If cRange.Characters(Start:=chk, Length:=1).Font.Bold = True Then
            BoldCHK = BoldCHK & cRange.Characters(Start:=chky, Length:=chk - chky).Text
            iLen = 1
            Do Until cRange.Characters(Start:=chk, Length:=1).Font.Bold <> cRange.Characters(Start:=chk + iLen, Length:=1).Font.Bold
                If st + iLen - 1 = en Then
                    Exit Do
                End If
                iLen = iLen + 1
            Loop
            BoldCHK = BoldCHK & "<B>" & cRange.Characters(Start:=chk, Length:=iLen).Text & "</B>"
            chk = chk + iLen - 1
            chky = chk + 1
        End If
    Next
    If chk <> chky Then
        BoldCHK = BoldCHK & cRange.Characters(Start:=chky, Length:=chk - chky).Text
        
    End If
End Function

Sub GetRGBValue(lColorValue, Red, Green, Blue)
    Red = Format(Hex(lColorValue Mod 256), "00")
    Green = Format(Hex(Int(lColorValue / 256) Mod 256), "00")
    Blue = Format(Hex(Int(lColorValue / 256 / 256)), "00")
End Sub
匿名回答2号

はてな記法に誤りがあり、ちゃんとコードが表示されていなかったので修正しました。

2018/12/18 08:58:35
匿名回答2号

一応補足しておきますと
・色文字はすべて対象。 font color=#XXXXXX となる。
・色文字と太字が重なっていても問題なし。

2018/12/20 14:10:20
匿名回答3号 No.3

匿名回答3号「匿名質問」を利用した質問に回答すると「匿名回答○号」と匿名で表示されます。
「匿名質問」では、ユーザー名を公開せずに匿名の質問ができます。
詳しくはこちら
2018/12/19 12:25:50

ブログにアップするのにHTMLでコーディングする?

エクセルの保存には、Webページ、単一ファイル Webページ というのがある。
これで保存して、FTPでアップロードすれば、日記サイトのページはできる。
ブログには、日記のページへのリンクか、自動的に飛ばすスクリプトを書いておけばいいんじゃないかと。

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません