Chấm dứt giá trị ô trong dấu ngoặc kép: VBA Excel VBA

Question

Tôi muốn đặt dấu ngoặc kép trong tất cả các ô trong một cột cụ thể. Tôi đã viết mã để đặt dấu ngoặc kép nhưng vấn đề là nó được đặt 3 dấu ngoặc kép xung quanh giá trị.

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 

Yêu cầu cơ bản là chia tệp excel theo cột B và lưu chúng dưới dạng tệp CSV.
Trong phần được phân tách, các giá trị của cột B và D phải được đặt trong dấu ngoặc kép.

Full Code:

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 

Sample Input Dữ liệu:

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

Output dự kiến ​​là hai file được tạo ra với dữ liệu sau

Tập 1:

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

Tập 2:

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

Resultant Output:

Tập 1:

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

Tương tự cho file 2

Vui lòng giúp đỡ. :)

Answer 1

Afaik, không có cách nào đơn giản để lừa Excel sử dụng dấu ngoặc kép xung quanh các số khi sử dụng quy trình "lưu dưới dạng csv" bình thường. Tuy nhiên, bạn có thể sử dụng VBA để lưu bất kỳ định dạng csv nào bạn muốn.

đang Đưa những ví dụ từ https://support.microsoft.com/en-us/help/291296/procedure-to-export-a-text-file-with-both-comma-and-quote-delimiters-in-excel

Chỉ cần thêm một nếu-tuyên bố để xác định xem có sử dụng dấu ngoặc kép hay không

' 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 

Các WorksheetFunction.IsText sẽ nhận ra con số của bạn dưới dạng văn bản nếu họ được nhập với một trước '(một báo giá cao)

Bạn sẽ cần điều chỉnh ví dụ để xuất phạm vi bạn muốn với tên tệp được đặt trước từ mã của bạn.

Answer 2

vấn đề là dòng này.

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

Dấu ngoặc kép bạn thêm sẽ được trích dẫn lại khi bạn xuất dưới dạng CSV, do đó ba trích dẫn mỗi bên của giá trị. Một lựa chọn tốt hơn tôi nghĩ là thay đổi định dạng số của myCell thành Text, chứ không phải là số. Tôi đã không cố gắng này nhưng tôi nghĩ rằng việc thay đổi nó để điều này sẽ giúp đỡ.

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

Chr (39) là dấu nháy đơn và khi bạn nhập nó làm ký tự đầu tiên của giá trị ô, nó buộc định dạng thành Văn bản.

Answer 3

Phụ nhỏ này sẽ thực hiện theo nhu cầu của bạn. Chỉ cần cung cấp cho nó một tên tập tin fname, phạm vi để xuất khẩu dưới dạng csv rg và một cột số column_with_quotes - vì vậy một cái gì đó như thế này nhưng với một phạm vi cho phù hợp:

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

Đây là phụ:

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