Question

我想在特定列的所有单元格中放置双引号。我已经写了代码来放双引号，但问题是它在值周围放了3个双引号。

 For Each myCell In ActiveWorkbook.Sheets("Sheet1").Range("B:B")
        If myCell.Value <> "" Then
            myCell.Value = Chr(34) & myCell.Value & Chr(34)
        End If
 Next myCell

基本要求是根据B列拆分excel文件并将其另存为CSV文件。
在拆分字段中，B列和D列的值必须用双引号括起来。

完整代码：

Option Explicit

Sub ParseItems()
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String
Dim myCell As Range, transCell As Range

'Sheet with data in it
   Set ws = Sheets("Sheet1")

'Path to save files into, remember the final \
    SvPath = "D:\SplitExcel\"

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
'Inserting new row to act as title, copying the data from first row in title, row deleted after use
    ws.Range("A1").EntireRow.Insert
    ws.Rows(2).EntireRow.Copy
    ws.Range("A1").Select
    ws.Paste
    vTitles = "A1:Z1"

'Choose column to evaluate from, column A = 1, B = 2, etc.
   vCol = 2
   If vCol = 0 Then Exit Sub

'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

'Speed up macro execution
   Application.ScreenUpdating = False

'Get a temporary list of unique values from key column
    ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

'Sort the temporary list
    ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Put list into an array for looping (values cannot be the result of formulas, must be constants)
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

'clear temporary worksheet list
    ws.Range("EE:EE").Clear

'Turn on the autofilter, one column only is all that is needed
    'ws.Range(vTitles).AutoFilter

'Loop through list one value at a time
    For Itm = 1 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
        'transCell = ws.Range("A2:A" & LR)
        ws.Range("A2:A" & LR).EntireRow.Copy
        Workbooks.Add
        Range("A1").PasteSpecial xlPasteAll
        Cells.Columns.AutoFit
        MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1



        For Each myCell In ActiveWorkbook.Sheets("Sheet1").Range("B:B")
            If myCell.Value <> "" Then
               myCell.Value = Chr(34) & myCell.Value & Chr(34)
            End If
        Next myCell



        ActiveWorkbook.SaveAs SvPath & "po" & MyArr(Itm) & ActiveWorkbook.Sheets("Sheet1").Range("D1") & "." & Date2Julian(Date), xlCSV, local:=False
        ActiveWorkbook.Close False

        ws.Range(vTitles).AutoFilter Field:=vCol
    Next Itm

'Cleanup
    ws.Rows(1).EntireRow.Delete
    ws.AutoFilterMode = False
    Application.ScreenUpdating = True
End Sub

Function Date2Julian(ByVal vDate As Date) As String

    Date2Julian = Format(DateDiff("d", CDate("01/01/" _
                  + Format(Year(vDate), "0000")), vDate) _
                  + 1, "000")



End Function

示例输入数据：

24833837    8013    70  1105
25057089    8013    75  1105
25438741    8013    60  1105
24833837    8014    70  1106
25057089    8014    75  1106
25438741    8014    60  1106

预期输出是使用以下数据创建的两个文件

文件1：

24833837,"8013",70,1105
25057089,"8013",75,1105
25438741,"8013",60,1105

文件2：

24833837,"8014",70,1106
25057089,"8014",75,1106
25438741,"8014",60,1106

结果输出：

文件1：

24833837,"""8013""",70,1105
25057089,"""8013""",75,1105
25438741,"""8013""",60,1105

文件2相同

请帮助。：）

Answer 1

Afaik，在使用普通的“另存为csv”-procedure时，没有简单的方法可以让Excel在数字周围使用引号。但是，您可以使用VBA以您喜欢的任何csv格式保存。

从https://support.microsoft.com/en-us/help/291296/procedure-to-export-a-text-file-with-both-comma-and-quote-delimiters-in-excel

获取代码示例

只需添加if语句即可确定是否使用引号

' Write current cell's text to file with quotation marks.
If WorksheetFunction.IsText(Selection.Cells(RowCount, ColumnCount)) Then
    Print #FileNum, """" & Selection.Cells(RowCount, _
        ColumnCount).Text & """";
Else
    Print #FileNum, Selection.Cells(RowCount, _
        ColumnCount).Text;
End If

如果使用前面的'（单引号）输入，则WorksheetFunction.IsText会将您的数字识别为文本

您需要调整示例以使用代码中预先给定的文件名导出所需的范围。

Answer 2

这个小子将按你的需要做。只需给它一个文件名fname，范围要导出为csv rg和一个列号column_with_quotes - 所以这样的东西，但有一个范围适合：

save_as_csv_with_optional_quotes SvPath & "po" & MyArr(Itm) & ActiveWorkbook.Sheets("Sheet1").Range("D1") & "." & Date2Julian(Date), Range("A1:C5"), 2

这是子：

Sub save_as_csv_with_optional_quotes(fname As String, rg As Range, column_with_quotes As Long)
    Dim ff, r, c As Long
    Dim loutput, cl As String

    ff = FreeFile
    Open fname For Output As ff

        For r = 1 To rg.Rows.Count
            loutput = ""
            For c = 1 To rg.Columns.Count
                If loutput <> "" Then loutput = loutput & ","
                cl = rg.Cells(r, c).Value
                If c = column_with_quotes Then cl = Chr$(34) & cl & Chr$(34)
                loutput = loutput & cl
            Next c
            Print #ff, loutput
        Next r
    Close ff
End Sub

Answer 3

问题在于这一行。

myCell.Value = Chr(34) & myCell.Value & Chr(34)

当您导出为CSV时，您添加的引号会再次被引用，因此三个引用值的每一边。我认为更好的选择是将myCell的数字格式更改为Text，而不是数字。我没有尝试过这个，但我认为改变它应该会有所帮助。

myCell.Value = Chr(39) & myCell.Value

Chr（39）是一个撇号，当你输入它作为单元格值的第一个字符时，它会强制格式为Text。

用双引号命名单元格值：Excel VBA宏

3 个答案: