ここから本文です

以下のVBAのコードを改善して頂けないでしょうか。 このコードは以下のような流れ...

qhy********さん

2020/4/2010:28:19

以下のVBAのコードを改善して頂けないでしょうか。
このコードは以下のような流れになっています。

①Sheet1 の Cells(1,5).Value を Range("B1") に代入
(B1 の値が変わると Sheet2 の内容が変わるようになっています。)
②Sheet2 の内容をコピーしてテキスト形式で保存
③Sheet2 の Cells(1,6).Value を Range("B1") に代入
(以下、繰り返し)

Sub test()
Dim i As Long
i = 5
With ThisWorkbook.Worksheets("Sheet1")
Do While .Cells(1, i).Value <> ""
.Range("B1").Value = .Cells(1, i).Value
Call test_sub
i = i + 1
Loop
End With
MsgBox "完了しました"
End Sub

Sub test_sub()
Dim filepath As String
Application.ScreenUpdating = False
ThisWorkbook.Worksheets("Sheet2").Copy
With ActiveSheet
filepath = ThisWorkbook.Path & "\" & Mid(.Range("A1").Value, 5) & ".yml"
With .Parent
.SaveAs filepath, xlText
.Close False
End With
End With
Application.ScreenUpdating = True
sjis2utf8 filepath
End Sub
Sub sjis2utf8(filepath As String)
Dim s As String
With CreateObject("Scripting.FileSystemObject").OpenTextFile(filepath)
s = .ReadAll
.Close
End With
With CreateObject("ADODB.Stream")
.Type = 2
.Charset = "UTF-8"
.Open
.WriteText s
.SaveToFile filepath, 2
.Close
End With
End Sub


このマクロを実行するとSheet2の内容をテキストファイルで出力してくれるのですが問題点があります。Sheet2 には
- { name: Apple, color: red }
のような形で記載している箇所が多くあるのですが、出力されたファイルは
" - { name: Apple, color: red }"
となっており、両端に二重引用符が付着してしまっています。
二重引用符が付着しないようにVBAのコードを改善して頂けないでしょうか。
Microsoft Forms 2.0 Object Library は参照可能にしてあります。

http://excel-magic.com/double-quotation/
上記のサイトを確認すると二重引用符が付着しないようにするためには
・一度 Word に貼り付けてからテキスト形式で保存する
・マクロ内で直接クリップボードにコピーする
などの解決方法があるようですが、実力不足で実現できていません。

補足Sheet2内に二重引用符を意図的に記載している箇所はありませんので
テキスト形式で保存したあと、保存したテキストファイルを開き、
テキスト全体から二重引用符を削除
または
二重引用符を空白に置換
の方法でも大丈夫です。

閲覧数:
21
回答数:
2
お礼:
50枚

違反報告

ベストアンサーに選ばれた回答

por********さん

2020/4/2011:06:21

こんにちは。
もし、「すべてのダブルクォーツを処理するのでもいい」
のだしたら、
s = replace(.ReadAll , chr(34) , "")
のアイデア

1行ずつ処理したい、
なら、
With CreateObject("Scripting.FileSystemObject").OpenTextFile(filepath)
s = .ReadAll
.Close
End With

set fso = CreateObject("Scripting.FileSystemObject")
set f1 = fso.OpenTextFile(filepath)
while not f1.eof
s(i) = f1.readline
if left(s(i),1) = chr(34) then
redim s(i)
s(i) = mid(s(i),2,len(s(i)-2)
wend
.Close

書き込みの場所
.WriteText join(s)
のアイデアです。

ためしてみてください

  • por********さん

    2020/4/2011:27:04

    それでしたら、最初のアイデア
    s = Replace(.ReadAll , chr(34) , "")
    で、試して見てください

    これ、一度ファイルからallで全部読み込みしてます。
    置き換えしてから、変数sに代入することになります。

    次のコントロールで、「空っぽ」の空間にwriteで流し込みし、
    空間そのものを、文字コードを変更して保存という方法です

    スペースに置き換えるのなら、
    s = Replace(.ReadAll , chr(34) , " ")
    です

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

質問した人からのコメント

2020/4/20 14:10:07

ありがとうございます。うまく機能していました。助かりました。

ベストアンサー以外の回答

1〜1件/1件中

por********さん

2020/4/2011:06:21

こんにちは。
もし、「すべてのダブルクォーツを処理するのでもいい」
のだしたら、
s = replace(.ReadAll , chr(34) , "")
のアイデア

1行ずつ処理したい、
なら、
With CreateObject("Scripting.FileSystemObject").OpenTextFile(filepath)
s = .ReadAll
.Close
End With

set fso = CreateObject("Scripting.FileSystemObject")
set f1 = fso.OpenTextFile(filepath)
while not f1.eof
s(i) = f1.readline
if left(s(i),1) = chr(34) then
redim s(i)
s(i) = mid(s(i),2,len(s(i)-2)
wend
.Close

書き込みの場所
.WriteText join(s)
のアイデアです。

ためしてみてください

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる