使用双引号引用单元格值：Excel VBAmacros

我想把双引号内的所有单元格在一个特定的列。 我已经写了代码，把双引号，但问题是这是价值三个双引号。

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 

示例input数据：

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

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

文件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”过程时，没有简单的办法可以把Excel引入数字周围。 但是，您可以使用VBA来保存您喜欢的任何csv格式。

以https://support.microsoft.com/zh-CN/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：

 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时会再次被引用，因此值的每一边都会有三个引号。 我认为更好的select是将myCell的数字格式更改为文本，而不是数字。 我还没有尝试过，但我认为改变它应该有所帮助。

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

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