Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Home : Excel 2016)
csvファイルを列によってダブルコーテーションつけない
投稿日時: 21/02/27 14:43:16
投稿者: あまあま
メールを送信

エクセルシートをCSVファイルにする時に
1行目はすべての列にダブルコーションを付けない。
2行目以降の1列目はダブルコーションを付けずない、2列目以降はダブルコーテンションを付ける。
コードがわかりません。エクセルシートからCSVファイル変換のコードを使うと、すべてダブルコーテンションがつかないので、ネットで調べた下記のものを使うとすべてダブルコーテンションが付きます。replaseですべての列にダブルコーテンションをつけているからでうが・・・
どなたか助けていただけませんか。
イメージ
1行目 1,203,0,,0,51
2行目 2,"125","0","","0","53"
 
 
    Dim reg, Filename As String
    Dim regSelection As Object
    Dim R, f, Val
    Dim fileSys, ts As Object
    Dim data As String
    Dim datareg As Integer
 
    Set fileSys = CreateObject("Scripting.FileSystemObject")
    Set reg = CreateObject("VBScript.RegExp")
    Set regSelection = ActiveSheet.UsedRange
    datareg = 1
    data = ""
 
    For Each R In regSelection
        Val = R.Text
        If datareg <> R.Row Then
           data = Left(data, Len(data) - 1)
           data = data & vbCrLf
           datareg = R.Row
        End If
        reg.Pattern = "^"
        Val = reg.Replace(Val, """")
        reg.Pattern = "$"
        Val = reg.Replace(Val, """")
        data = data & Val & ","
    Next
 
     data = Left(data, Len(data) - 1)
 
    Filename = Application.GetSaveAsFilename(, "CSVファイル(*.csv),*.csv")
    Set ts = fileSys.CreateTextFile(Filename, True, False)
    ts.WriteLine (data)
    ts.Close
 
よろしくお願いいたします。

回答
投稿日時: 21/02/27 15:05:40
投稿者: WinArrow
投稿者のウェブサイトに移動

1行目の判断
 
If R.Row = regSelection.Row Then
   '1行目です。
 
同様に
1列目の判断
If R.Column = regSelection.Column Then
   '1列目です。
 
 

投稿日時: 21/02/27 16:10:41
投稿者: あまあま
メールを送信

WinArrowさん回答ありがとうございます。
1行目の判断
If R.Row = regSelection.Row Then
   '1行目です。
同様に
1列目の判断
If R.Column = regSelection.Column Then
   '1列目です。
を例えば下記のようにすればよいのでしょうか?
すみません。わかっていなくて。
 If R.Row = regSelection.Row Then
     reg.Pattern = "^"
         Val = reg.Replace(Val, "")
         reg.Pattern = "$"
         Val = reg.Replace(Val, "")
         data = data & Val & ","

回答
投稿日時: 21/02/27 16:45:24
投稿者: WinArrow
投稿者のウェブサイトに移動

冷たいようですが、
ステップ実行で確かめてみることをお勧めします。

回答
投稿日時: 21/02/27 21:18:00
投稿者: WinArrow
投稿者のウェブサイトに移動

回答ではありませんが、
1つの項目に5行のコードで処理している
分かりにくいと思いませんか?

引用:

        reg.Pattern = "^"
         Val = reg.Replace(Val, """")
         reg.Pattern = "$"
         Val = reg.Replace(Val, """")
         data = data & Val & ","     

これを1行のコードで記述すると
        data = """" & val & """" & vbLf & ","
こうなります。正規表現は使っていませんが・・・・

回答
投稿日時: 21/02/27 22:11:37
投稿者: WinArrow
投稿者のウェブサイトに移動

コードに間違いがありました。訂正します
  
 > data = """" & val & """" & vbLf & ","
 ↓
         data = """" & val & """" & ","
 

回答
投稿日時: 21/02/28 00:05:03
投稿者: WinArrow
投稿者のウェブサイトに移動

セル個数の個数が不明ですが、配列変数に入れてアクセスする方が処理が速いです。
 対象範囲のセルの値を配列変数に一発で格納することができるが、
それは、Valueに限られています。
  
そこで、作業シートに、Text形式で複写します。
そして、作業シートの値を 配列変数に格納します。
  
配列変数を「行」単位に文字列結合する方法を提案します。
 

 Dim RX As Long, CX As Long, wsht As Worksheet 
 Dim Val, dat, DATA1 As String, DATA2 As String 
     '作業シート作成と、対象範囲セルの「値」複写 
    Sheets.Add before:=Sheets(ActiveSheet) 
     Set wsht = acivesheet 
     wsht.Next.UsedRange.Copy 
     wsht.Range("A1").Select 
     wsht.PasteSpecial Paste:=xlPasteValues 
     Application.CutCopyMode = False 
      
     DATA1 = "" 
     With wsht 
         '配列変数に格納 
        Val = .UsedRange.Value 
         For RX = LBound(Val) To UBound(Val) 
             '1行毎の処理 
            '1次元の配列に入れると、一発で「,」を挿入できる 
            ReDim dat(1 To UBound(Val, 2)) 
             DATA2 = "" 
             For CX = LBound(Val, 2) To UBound(Val, 2) 
                 If RX = 1 Then 
                     dat(CX) = Val(RX, CX) 
                 Else 
                     If CX = 1 Then 
                         dat(CX) = Val(RX, CX) 
                     Else 
                         dat(CX) = """" & Val(RX, CX) & """" 
                     End If 
                 End If 
             Next 
             DATA2 = DATA2 & Join(dat, ",") 
             '全体の文字列に結合する 
            DATA1 = DATA1 & vbCrLf & DATA2 
         Next 
     End With 
     DATA1 = DATA1 & vbCrLf 
     MsgBox DATA1 
  
 'さいごに作業シートを削除する 
wsht.Delete 

回答
投稿日時: 21/02/28 08:31:42
投稿者: MMYS

あまあま さんの引用:

1行目はすべての列にダブルコーションを付けない。
2行目以降の1列目はダブルコーションを付けずない、2列目以降はダブルコーテンションを付ける。

1行目を処理
2行目以降を処理
と処理を分ければ、IF文の判定は不要です。
同様に列も1列目と2列目以降でから、IF文の判定は不要です。
 
また、1行目と2行目以降はダブルコーテーションの有無です。
つまり、1行目は空文字、2行目以降はダブルコーテンションを渡しています。
 
なお、UsedRangeで、保存範囲の取得はおすすめできません。
https://www.limecode.jp/entry/syntax/getlastrow
 
Sub Sample()
    Dim R           As Long
    Dim RowStart    As Long
    Dim RowLast     As Long
    Dim ColumStart  As Long
    Dim ColumLast   As Long
    Dim data        As String

    With ActiveSheet.UsedRange
        RowStart = .Rows.Row
        RowLast = .Rows.Count + (RowStart - 1)
        ColumStart = .Columns.Column
        ColumLast = .Columns.Count + (ColumStart - 1)
    End With
    
    data = ""

    '1行目
    data = WriteData(RowStart, ColumStart, ColumLast, "")

    '2行目以降
    For R = RowStart + 1 To RowLast
        data = data & WriteData(R, ColumStart, ColumLast, """")
    Next

    MsgBox data

End Sub

'1行を処理する
'  TargetRow  処理する行を指定する
'  ColumStart 開始列を指定する
'  ColumLast  終了列を指定する
'  w   ダブルコーテーションの有無
Function WriteData(TargetRow As Long _
                 , ColumStart As Long, ColumLast As Long, w As String) As String
    Dim C       As Long
    Dim data  As String
        
    '1列目
    data = Cells(TargetRow, ColumStart).Value
    
    '2列目以降
    For C = ColumStart + 1 To ColumLast
       data = data & "," & w & Cells(TargetRow, C).Value & w
    Next
        
    data = data & vbCrLf
    WriteData = data
        
End Function


 

投稿日時: 21/02/28 09:54:03
投稿者: あまあま
メールを送信

 WinArrowさん、MMYSさんありがとうございます。
皆さんのコードを参考に実行してみたいと思います。
まだまだ勉強不足で皆さんのようにいきませんが、何とか頑張ってみます。
本当に感謝しております。

回答
投稿日時: 21/03/01 23:47:38
投稿者: たらのり

こんばんは
 
すでにお二方から提示がありますが,ループを素直に
行と列の二重ループに分解すると理解しやすいと思います。
 

Sub Nunclenicer()

    Dim rng As Excel.Range

    Dim nr  As Long     ' 出力範囲の行数
    Dim nc  As Long     ' 出力範囲の列数
    Dim ir  As Long     ' 行インデクス
    Dim ic  As Long     ' 列インデクス
    
    Dim var As String   ' 値
    Dim rec As String   ' レコード(行)
    Dim dat As String   ' すべてのレコード
    
    Dim csvName As String   ' 出力ファイル名
    
    Const QUOTE = """"      ' 二重引用符
    
    Set rng = ActiveSheet.UsedRange ' 出力範囲
    
    nr = rng.Rows.Count     ' 行数
    nc = rng.Columns.Count  ' 列数
    
    dat = ""
    For ir = 1 To nr        ' 行のループ
        
        rec = ""
        For ic = 1 To nc    ' 列のループ
            var = rng.Cells(ir, ic).Text
            
            If (ir = 1 Or ic = 1) Then
                ' 1行め、または 1列めは引用符で括らない
            Else
                var = QUOTE & var & QUOTE
            End If
            
            ' 項目の連結
            rec = rec & IIf(ic = 1, "", ",") & var
        Next ic
    
        ' レコードの連結
        dat = dat & rec & vbCrLf
    Next ir
    
    csvName = Application.GetSaveAsFilename(, "CSVファイル(*.csv),*.csv")

    With CreateObject("Scripting.FileSystemObject")
        With .CreateTextFile(csvName, True, False)
            Call .Write(dat)    ' dat の末尾は vbCrLf
            Call .Close
        End With
    End With

End Sub

# まったく面白みのないコードですねww

投稿日時: 21/03/03 09:08:01
投稿者: あまあま
メールを送信

たらのりさん
ありがとうございます。コードを参考に勉強させていただきます。感謝しております。