Вопрос:
Я ищу макрос VBA для экспорта данных в csv. Я нашел этот код, который после некоторой настройки делает отличную работу. Однако при копировании из диапазона 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
Обновить:
В ответ на действия шаганов. Список параметров в первой строке предназначен для установки другим макросом как таковым:
Sub ExportVisibleAsCSV Call ExportListOrTable(newBook:=True, willNameSheet:=False, asCSV:=True, visibleOnly:=True) End Sub Лучший ответ:
Теперь обновляется код примера:
Хорошо глядя на код, который вы опубликовали, я вижу bool с именем visibleOnly, но я не вижу, где он устанавливается. Ваша способность логики достичь UseRange.Copy полностью зависит от того, что установлено на false. Комментарий выше ACell.ListObject.Range.Copy указывает, что если вы достигнете этого утверждения, вы будете копировать только видимые ячейки. Чтобы скопировать скрытые ячейки, visibleOnly нужно установить в false (минуя остальную часть содержимого CCount). Поэтому мне было бы интересно узнать, как этот bool установлен и проверяет, для чего его значение установлено, когда вы используете свой код.
Обновление 2:
Вам нужно как-то установить значение вашего visibleOnly boolean.
здесь некоторый код, который я редактировал, создает окно сообщения, которое позволяет пользователю сказать “да” или “нет”, чтобы “вы тоже хотите скопировать скрытые данные”? этот ответ будет диктовать значение visibleOnly, которое, в свою очередь, диктует, какой поток они вводят.
В дополнение к этому, ваше предположение, что ACell.ListObject.Range.Copy будет только копировать видимые ячейки, похоже, было неправильным. Вместо этого он заменяется специальным типом клеток для видимых клеток.
Наконец, vbYesNo фактически не возвращает логическое значение. Вместо этого он возвращает vbYes или vbNo, которые являются перечислениями типа vb (значения 6 и 7 соответственно). Поэтому установка bool в значение vbYesNo всегда будет возвращать значение True (поскольку значение существует и по существу оно просто оценивает iferror).
Поэтому я тоже изменил этот бит, поэтому теперь он корректно проверяет условие “Да/Нет” на вашем пользователе (который больше не является bool).
здесь код:
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
Назначьте значение диапазона для целевого диапазона вместо использования метода.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
Это также имеет преимущество, заключающееся в том, что вы не можете использовать любой пользователь в буфере обмена.
