[英]From XLS into CSV - macro Save As visual option
我很高興與優秀的程序員一起來到這里，並希望我能學到很多。 我對這種編程方式還是陌生的，因此給您帶來的不便，我們深感抱歉。
我正在使用下面的VBA代碼將文件從XLS傳輸到CSV 。 將xls文件轉換為csv格式后，它會將我新創建的csv文件自動保存在與原始xls文件相同的目錄中。
我想將csv文件名Save As為
先感謝您。
' ---------------------- Directory Choosing Helper Functions -----------------------
' Excel and VBA do not provide any convenient directory chooser or file chooser
' dialogs, but these functions will provide a reference to a system DLL
' with the necessary capabilities
Private Type BROWSEINFO ' used by the function GetFolderName
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim X As Long, pos As Integer
bInfo.pidlRoot = 0& ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
' the dialog title
Else
bInfo.lpszTitle = Msg ' the dialog title
End If
bInfo.ulFlags = &H1 ' Type of directory to return
X = SHBrowseForFolder(bInfo) ' display the dialog
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal X, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetFolderName = Left(path, pos - 1)
Else
GetFolderName = ""
End If
End Function
'---------------------- END Directory Chooser Helper Functions ----------------------
Public Sub DoTheExport()
Dim FName As Variant
Dim Sep As String
Dim wsSheet As Worksheet
Dim nFileNum As Integer
Dim csvPath As String
Sep = ";"
csvPath = Application.ActiveWorkbook.path
Dim brojac As Integer
brojac = 0
For Each wsSheet In Worksheets
If brojac > 0 Then Exit For
wsSheet.Activate
nFileNum = FreeFile
Open csvPath & "\" & _
Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) & ".csv" For Output As #nFileNum ' wsSheet.Name
ExportToTextFile CStr(nFileNum), Sep, False
Close nFileNum
brojac = brojac + 1
Next wsSheet
End Sub
Public Sub ExportToTextFile(nFileNum As Integer, _
Sep As String, SelectionOnly As Boolean)
Dim WholeLine As String
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String
Application.ScreenUpdating = False
On Error GoTo EndMacro:
If SelectionOnly = True Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Else
With ActiveSheet.UsedRange
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #nFileNum, WholeLine
Next RowNdx
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
問題可能出在這里。 這部分代碼必須重新編寫或更正。 這是調用其他函數的主要功能。
Public Sub DoTheExport()
Dim FName As Variant
Dim Sep As String
Dim wsSheet As Worksheet
Dim nFileNum As Integer
Dim csvPath As String
Sep = ";"
csvPath = Application.ActiveWorkbook.path
Dim brojac As Integer
brojac = 0
For Each wsSheet In Worksheets
If brojac > 0 Then Exit For
wsSheet.Activate
nFileNum = FreeFile
Open csvPath & "\" & _
Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) & ".csv" For Output As #nFileNum ' wsSheet.Name
ExportToTextFile CStr(nFileNum), Sep, False
Close nFileNum
brojac = brojac + 1
Next wsSheet
End Sub
這是三個關鍵的更新行：
strFileName = Application.GetSaveAsFilename(Left$(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5), "CSV (Comma delimited) (*.csv), *.csv")
If strFileName = "False" Then Exit Sub
Open strFileName For Output As #nFileNum
更新的代碼
Public Sub DoTheExport()
Dim FName As Variant
Dim Sep As String
Dim wsSheet As Worksheet
Dim nFileNum As Integer
Dim csvPath As String
Dim strFileName As String
Sep = ";"
csvPath = Application.ActiveWorkbook.path
Dim brojac As Long
brojac = 0
For Each wsSheet In Worksheets
If brojac > 0 Then Exit For
wsSheet.Activate
nFileNum = FreeFile
strFileName = Application.GetSaveAsFilename(Left$(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5), "CSV (Comma delimited) (*.csv), *.csv")
If strFileName = "False" Then Exit Sub
Open strFileName For Output As #nFileNum
ExportToTextFile CStr(nFileNum), Sep, False
Close nFileNum
brojac = brojac + 1
Next wsSheet
End Sub
更有效的CSV代碼
Const的情況下嘗試從ThisWorkbook或Sheet Code窗格運行該代碼，則會導致錯誤。 ThisWorkbook和Sheet代碼部分應僅保留用於事件編碼，“正常” VBA應該從標准代碼模塊運行。 C:\\test\\myfile.csv 。 您可能需要以編程方式設置輸出文件，例如作為功能參數。 Save As... CSV Text菜單選項。 碼
Const sFilePath = "C:\test\myfile.csv"
Const strDelim = ","
Sub CreateCSV_Output()
Dim ws As Worksheet
Dim rng1 As Range
Dim X
Dim lRow As Long
Dim lCol As Long
Dim strTmp As String
Dim lFnum As Long
lFnum = FreeFile
Open sFilePath For Output As lFnum
For Each ws In ActiveWorkbook.Worksheets
'test that sheet has been used
Set rng1 = ws.UsedRange
If Not rng1 Is Nothing Then
'only multi-cell ranges can be written to a 2D array
If rng1.Cells.Count > 1 Then
X = ws.UsedRange.Value2
'The code TRANSPOSES COLUMNS AND ROWS by writing strings column by column
For lCol = 1 To UBound(X, 2)
'write initial value outside the loop
strTmp = IIf(InStr(X(1, lCol), strDelim) > 0, """" & X(1, lCol) & """", X(1, lCol))
For lRow = 2 To UBound(X, 1)
'concatenate long string & (short string with short string)
strTmp = strTmp & (strDelim & IIf(InStr(X(lRow, lCol), strDelim) > 0, """" & X(lRow, lCol) & """", X(lRow, lCol)))
Next lRow
'write each line to CSV
Print #lFnum, strTmp
Next lCol
Else
Print #lFnum, IIf(InStr(ws.UsedRange.Value, strDelim) > 0, """" & ws.UsedRange.Value & """", ws.UsedRange.Value)
End If
End If
Next ws
Close lFnum
MsgBox "Done!", vbOKOnly
End Sub
Sub CreateCSV_FSO()
Dim objFSO
Dim objTF
Dim ws As Worksheet
Dim lRow As Long
Dim lCol As Long
Dim strTmp As String
Dim lFnum As Long
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.createtextfile(sFilePath, True, False)
For Each ws In ActiveWorkbook.Worksheets
'test that sheet has been used
Set rng1 = ws.UsedRange
If Not rng1 Is Nothing Then
'only multi-cell ranges can be written to a 2D array
If rng1.Cells.Count > 1 Then
X = ws.UsedRange.Value2
'The code TRANSPOSES COLUMNS AND ROWS by writing strings column by column
For lCol = 1 To UBound(X, 2)
'write initial value outside the loop
strTmp = IIf(InStr(X(1, lCol), strDelim) > 0, """" & X(1, lCol) & """", X(1, lCol))
For lRow = 2 To UBound(X, 1)
'concatenate long string & (short string with short string)
strTmp = strTmp & (strDelim & IIf(InStr(X(lRow, lCol), strDelim) > 0, """" & X(lRow, lCol) & """", X(lRow, lCol)))
Next lRow
'write each line to CSV
objTF.writeline strTmp
Next lCol
Else
objTF.writeline IIf(InStr(ws.UsedRange.Value, strDelim) > 0, """" & ws.UsedRange.Value & """", ws.UsedRange.Value)
End If
End If
Next ws
objTF.Close
Set objFSO = Nothing
MsgBox "Done!", vbOKOnly
End Sub
宏將每個工作表保存到具有可視文件選擇器的單獨xls文件中
[英]macro to save each worksheet into separate xls files with visual file chooser
使用從xls文件讀取的數據集更新單元格並保存到CSV文件
[英]Updating cells using dataset read from xls file and save to CSV file
如何從〜1500個格式相同的txt文件中的每一個提取一行並將值保存到csv或xls？
[英]How to extract one line from each of ~1500 identically formatted txt files and save values to csv or xls?
讀取兩個文件，一個csv和xls，並根據子網（csv）/ ip（xls）匹配將列從csv帶到xls
[英]Reading two files, a csv and xls, and bring columns from csv to xls based on subnet(csv)/ip(xls) match
聲明:本站的技術帖子網頁，遵循CC BY-SA 4.0協議，如果您需要轉載，請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.