我正在寻找VBA宏来将数据导出到csv。我找到了this code 经过一些调整后做得很好。但是,从范围复制时,Excel似乎忽略隐藏列,而我希望CSV包含所有列。有没有人发现简洁的方法对此进行编码?
这是我到目前为止的代码:
Sub ExportListOrTable(Optional newBook As Boolean, Optional willNameSheet As Boolean, Optional asCSV As Boolean, Optional visibleOnly As Boolean)
'Sub CopyListOrTable2NewWorksheet()
'Works in Excel 2003 and Excel 2007. Only copies visible data.
'code source: https://msdn.microsoft.com/en-us/library/dd637097%28v=office.11%29.aspx
'improved by: Tzvi
' - replaced new worksheet with new workbook
'params:
' newBook: To create a new new sheet in the current workbook or (default) in a new workbook
' willNameSheet: To offer the user to name the sheet or (default) leave the default names
' asCSV: not implemented - will always save as CSV
' visibleOnly: to filter out any hidden columns - default false
'TODO
' -add parameter list for following options:
' - if table was not selected, copy activesheet.usedRange
' - optional saveFileType
' -
Dim New_Ws As Worksheet
Dim ACell, Data As Range
Dim CCount As Long
Dim ActiveCellInTable As Boolean
Dim CopyFormats, retrySave As Variant
Dim sheetName, user, defaultFileName, fileSaveName As String
Dim userChoice As Boolean
'Check to see if the worksheet or workbook is protected. TODO this may not be necessary anymore
If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
MsgBox "This macro will not work when the workbook or worksheet is write-protected."
Exit Sub
End If
'Set a reference to the ActiveCell. You can always use ACell to
'point to this cell, no matter where you are in the workbook.
Set ACell = activeCell
'Test to see if ACell is in a table or list. Note that by using ACell.ListObject, you
'do not need to know the name of the table to work with it.
On Error Resume Next
ActiveCellInTable = (ACell.ListObject.Name <> "")
On Error GoTo 0
'TODO here we will select the fields to export
'If the cell is in a list or table run the code.
If ActiveCellInTable = True Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
If visibleOnly = True Then
'Test if there are more than 8192 separate areas. Excel only supports
'a maximum of 8,192 non-contiguous areas through VBA macros and manual.
On Error Resume Next
With ACell.ListObject.ListColumns(1).Range 'TODO remove this "with"
CCount = .SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
End With
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 individual areas, so it is not possible to " & _
"copy the visible data to a new worksheet. Tip: Sort your " & _
"data before you apply the filter and try this macro again.", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
Else
'Copy the visible cells.
ACell.ListObject.Range.Copy
End If
Else
'The user indicated he wants to copy hidden columns too.
'**********************************************************
'HOW DO I PROPERLY IMPLEMENT THIS PART?
'**********************************************************
MsgBox ("You wanted to copy hidden columns too?")
ActiveSheet.UsedRange.Copy
End If
Else
' MsgBox "Select a cell in your list or table before you run the macro.", _
' vbOKOnly, "Copy to new worksheet"
userChoice = MsgBox("A Table/Table protion is not selected. Do you want to export the entire page?", vbYesNo)
If userChoice = False Then Exit Sub
ActiveSheet.UsedRange.Copy
'Exit Sub
End If
'Add a new Worksheet/WorkBook.
If newBook = False Then
Set New_Ws = Worksheets.Add(after:=Sheets(ActiveSheet.Index))
Else
Set New_Ws = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
End If
'Prompt the user for the worksheet name.
If willNameSheet = True Then
sheetName = InputBox("What is the name of the new worksheet?", _
"Name the New Sheet")
On Error Resume Next
New_Ws.Name = sheetName
If Err.Number > 0 Then
MsgBox "Change the name of sheet : " & New_Ws.Name & _
" manually after the macro is ready. The sheet name" & _
" you typed in already exists or you use characters" & _
" that are not allowed in a sheet name."
Err.Clear
End If
On Error GoTo 0
End If
'Paste the data into the new worksheet.
With New_Ws.Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValuesAndNumberFormats
.Select
Application.CutCopyMode = False
End With
Application.ScreenUpdating = False
'If you did not create a table, you have the option to copy the formats.
If ActiveCellInTable = False Then
Application.Goto ACell
CopyFormats = MsgBox("Do you also want to copy the Formatting?", _
vbOKCancel + vbExclamation, "Copy to new worksheet")
If CopyFormats = vbOK Then
ACell.ListObject.Range.Copy
With New_Ws.Range("A1")
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End If
'Select the new worksheet if it is not active.
Application.Goto New_Ws.Range("A1")
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'Now we're ready to save our new file as excel format
defaultFileName = ActiveWorkbook.Name
user = Environ("userprofile")
'marker getfilename: to return to if we need to look for a new filename
getfilename:
ChDir user & "\Desktop"
fileSaveName = Application.GetSaveAsFilename(defaultFileName & ".csv", "Comma Delimited Format (*.csv), *.csv")
If fileSaveName <> "False" Then
'error handling for 'file already exists and the user clicks 'no'
On Error Resume Next
ActiveWorkbook.SaveAs fileName:=fileSaveName, FileFormat:=xlCSV, ReadOnlyRecommended:=True, CreateBackup:=False, ConflictResolution:=xlUserResolution
If Err.Number = 1004 Then
'Offer user two options: To try a different filename or cancel the entire export
retrySave = MsgBox(Err.Description, vbRetryCancel, "Error creating file")
If retrySave = vbRetry Then
GoTo getfilename
Else
GoTo cancelprocedure
End If
End If
On Error GoTo 0
Else
GoTo cancelprocedure
End If
Exit Sub
cancelprocedure:
ActiveWorkbook.Close saveChanges:=False
Exit Sub
End Sub
更新
回应shagans的关注。第一行的参数列表应由另一个宏设置:
Sub ExportVisibleAsCSV
Call ExportListOrTable(newBook:=True, willNameSheet:=False, asCSV:=True, visibleOnly:=True)
End Sub
答案 0 :(得分:2)
现在更新示例代码:
好的看看你发布的代码,我看到一个名为visibleOnly的bool,但我看不到它的设置。逻辑到达UsedRange.Copy的能力完全取决于被设置为false的能力。 ACell.ListObject.Range.Copy上面的注释表示如果您到达该语句,则只复制可见单元格。为了复制隐藏的单元格,需要将visibleOnly设置为false(绕过其余的CCount内容)。因此,我有兴趣了解bool的设置方式,并检查运行代码时其值的设置。
更新2:
您需要以某种方式设置visibleOnly布尔值。
这里是我编辑的一些代码,它创建了一个消息框,允许用户说“是”或“否”,“你是否也要复制隐藏数据?”这个答案将决定visibleOnly的价值,而这反过来决定了他们进入的流量。
除此之外,您假设ACell.ListObject.Range.Copy仅复制可见单元格似乎是不正确的。相反,它被替换为可见细胞的特殊细胞类型。
最后,vbYesNo实际上并不返回布尔值。相反,它返回vbYes或vbNo,它们是vb类型的枚举器(分别为值6和7)。因此,将bool设置为vbYesNo的值将始终返回True(作为值存在且基本上它仅评估iferror)。
所以我也改变了这一点,所以它现在正确地检查了你的用户选择上的是/否条件(这不再是一个布尔)。
这是代码:
Dim ACell, Data As Range
Dim CCount As Long
Dim ActiveCellInTable As Boolean
Dim CopyFormats, retrySave As Variant
Dim sheetName, user, defaultFileName, fileSaveName As String
'Check to see if the worksheet or workbook is protected. TODO this may not be necessary anymore
If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
MsgBox "This macro will not work when the workbook or worksheet is write-protected."
Exit Sub
End If
'Set a reference to the ActiveCell. You can always use ACell to
'point to this cell, no matter where you are in the workbook.
Set ACell = ActiveCell
'Test to see if ACell is in a table or list. Note that by using ACell.ListObject, you
'do not need to know the name of the table to work with it.
On Error Resume Next
ActiveCellInTable = (ACell.ListObject.Name <> "")
On Error GoTo 0
'TODO here we will select the fields to export
'If the cell is in a list or table run the code.
If ActiveCellInTable = True Then
CopyHidden = MsgBox("Would you like to copy hidden data also?", vbYesNo, "Copy Hidden Data?")
If CopyHidden = vbYes Then
visibleOnly = False
ElseIf CopyHidden = vbNo Then
visibleOnly = True
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
If visibleOnly = True Then
'Test if there are more than 8192 separate areas. Excel only supports
'a maximum of 8,192 non-contiguous areas through VBA macros and manual.
On Error Resume Next
With ACell.ListObject.ListColumns(1).Range 'TODO remove this "with"
CCount = .SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
End With
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 individual areas, so it is not possible to " & _
"copy the visible data to a new worksheet. Tip: Sort your " & _
"data before you apply the filter and try this macro again.", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
Else
'Copy the visible cells.
ACell.ListObject.Range.SpecialCells(xlCellTypeVisible).Copy
' Only visible cells within the table are now in clipboard
End If
Else
'The user indicated he wants to copy hidden columns too.
MsgBox ("You wanted to copy hidden columns too?")
ACell.ListObject.Range.Copy
' All table data cells including hidden are now in clipboard
End If
Else
' MsgBox "Select a cell in your list or table before you run the macro.", _
' vbOKOnly, "Copy to new worksheet"
userChoice = MsgBox("A Table/Table protion is not selected. Do you want to export the entire page?", vbYesNo)
If userChoice = vbNo Then Exit Sub
ActiveSheet.UsedRange.Copy
'Entire sheet range is now in clipboard (this is not always accurate)
'Exit Sub
End If
答案 1 :(得分:1)
将范围的值指定给目标范围,而不是使用.Copy方法:
Sub ExportCSV(source As Range, filename As String)
Dim temp As Workbook
Set temp = Application.Workbooks.Add
Dim sheet As Worksheet
Set sheet = temp.Worksheets(1)
Dim target As Range
'Size the target range to the same dimension as the source range.
Set target = sheet.Range(sheet.Cells(1, 1), _
sheet.Cells(source.Rows.Count, source.Columns.Count))
target.Value = source.Value
temp.SaveAs filename, xlCSV
temp.Close False
End Sub
这样做的好处是不会让用户在剪贴板上看到任何内容。