セルに以下の様な文字が入っています。
今日は
京都へ
行ってきます。
セル内はALT+ENTERキーで改行されています。
このセルの中の改行を読み取り<br>タグを付け以下のような処理をするプログラムを作成することは可能でしょうか？
今日は<br><br>
京都へ<br><br><br>
行ってきます。
この処理を値がある列A全てのセルに行うVBAプログラムを書ける方おりましたら
コードを書いていただけないでしょうか？
お手数をおかけしますがよろしくお願いいたします。
No.3
3454
969
10pt
sub101さんのコードがシンプルでいいですね。私の方は力技で。
Sub Macro() Dim str As String Dim i As Long Dim j As Long Dim k As Long Dim r As Long Dim LastRow As Long LastRow = Cells(Rows.Count, 1).End(xlUp).Row For r = 1 To LastRow If Cells(r, 1).Value <> "" Then str = Cells(r, 1).Value j = 0 For i = 1 To Len(str) If Mid(str, i + j, 1) = Chr(&HA00) Then k = 0 If i > 1 Then While Mid(str, i + j - k - 1, 1) = Chr(&HA00) k = k + 1 Wend End If str = Left(str, i + j - k - 1) & "<br>" & Mid(str, i + j - k) j = j + 4 End If Next i Cells(r, 1).Value = str End If Next r End Sub
No.1
5960633
35pt
セルA1に変換元文字列、セルB1に変換後の文字列を入れるとすると、VBAのコードは以下の通り。
269
267
s1 = Range("A1").Value
s2 = Replace(s1, Chr(&HA00), "<br />")
Range("B1").Value = s2
確認していないのですが、UnicodeベースのExcelであれば、セル内改行コードは &HA0 です。
もしうまく動かないようでしたら、「セル内の改行コードに注意」を参考に、セル内改行コードを確認してください。
No.2
10
35pt
こんなかんじかな？
Dim target As Range
Dim buf As String
Const SOURCE = vbLf & "<br>" & vbLf
Const SEARCH = "<br>" & vbLf & vbLf
For Each target In Columns("A").SpecialCells(xlCellTypeConstants)
buf = Replace(target, vbLf, "<br>" & vbLf)
Do While InStr(buf, SOURCE)
buf = Replace(buf, SOURCE, SEARCH, , 1)
Loop
target = buf
buf = Empty
Next
ご回答ありがとうございます。
プログラムちゃんと実行されました。
No.3
3454969
ここでベストアンサー
10pt
sub101さんのコードがシンプルでいいですね。私の方は力技で。
Sub Macro() Dim str As String Dim i As Long Dim j As Long Dim k As Long Dim r As Long Dim LastRow As Long LastRow = Cells(Rows.Count, 1).End(xlUp).Row For r = 1 To LastRow If Cells(r, 1).Value <> "" Then str = Cells(r, 1).Value j = 0 For i = 1 To Len(str) If Mid(str, i + j, 1) = Chr(&HA00) Then k = 0 If i > 1 Then While Mid(str, i + j - k - 1, 1) = Chr(&HA00) k = k + 1 Wend End If str = Left(str, i + j - k - 1) & "<br>" & Mid(str, i + j - k) j = j + 4 End If Next i Cells(r, 1).Value = str End If Next r End Sub
tomokazu
2008/09/23 13:19:46
aiomock
きゃづみぃ
2
1
1
ご回答ありがとうございます。