Excel VBA: How to copy entire range including hidden columns -
i'm looking vba macro export data csv. found this code after tweaking great job. however, when copying range, excel seems ignore hidden columns while want csv contain columns. has discovered concise way code this?
here code have far:
sub exportlistortable(optional newbook boolean, optional willnamesheet boolean, optional ascsv boolean, optional visibleonly boolean) 'sub copylistortable2newworksheet() 'works in excel 2003 , excel 2007. copies visible data. 'code source: https://msdn.microsoft.com/en-us/library/dd637097%28v=office.11%29.aspx 'improved by: tzvi ' - replaced new worksheet new workbook 'params: ' newbook: create new new sheet in current workbook or (default) in new workbook ' willnamesheet: offer user name sheet or (default) leave default names ' ascsv: not implemented - save csv ' visibleonly: filter out hidden columns - default false 'todo ' -add parameter list following options: ' - if table not selected, copy activesheet.usedrange ' - optional savefiletype ' - dim new_ws worksheet dim acell, data range dim ccount long dim activecellintable boolean dim copyformats, retrysave variant dim sheetname, user, defaultfilename, filesavename string dim userchoice boolean 'check see if worksheet or workbook protected. todo may not necessary anymore if activeworkbook.protectstructure = true or activesheet.protectcontents = true msgbox "this macro not work when workbook or worksheet write-protected." exit sub end if 'set reference activecell. can use acell 'point cell, no matter in workbook. set acell = activecell 'test see if acell in table or list. note using acell.listobject, 'do not need know name of table work it. on error resume next activecellintable = (acell.listobject.name <> "") on error goto 0 'todo here select fields export 'if cell in list or table run code. if activecellintable = true application .screenupdating = false .enableevents = false end if visibleonly = true 'test if there more 8192 separate areas. excel supports 'a maximum of 8,192 non-contiguous areas through vba macros , manual. on error resume next acell.listobject.listcolumns(1).range 'todo remove "with" ccount = .specialcells(xlcelltypevisible).areas(1).cells.count end on error goto 0 if ccount = 0 msgbox "there more 8192 individual areas, not possible " & _ "copy visible data new worksheet. tip: sort " & _ "data before apply filter , try macro again.", _ vbokonly, "copy new worksheet" exit sub else 'copy visible cells. acell.listobject.range.copy end if else 'the user indicated wants copy hidden columns too. '********************************************************** 'how implement part? '********************************************************** msgbox ("you wanted copy hidden columns too?") activesheet.usedrange.copy end if else ' msgbox "select cell in list or table before run macro.", _ ' vbokonly, "copy new worksheet" userchoice = msgbox("a table/table protion not selected. want export entire page?", vbyesno) if userchoice = false exit sub activesheet.usedrange.copy 'exit sub end if 'add new worksheet/workbook. if newbook = false set new_ws = worksheets.add(after:=sheets(activesheet.index)) else set new_ws = workbooks.add(xlwbatworksheet).worksheets(1) end if 'prompt user worksheet name. if willnamesheet = true sheetname = inputbox("what name of new worksheet?", _ "name new sheet") on error resume next new_ws.name = sheetname if err.number > 0 msgbox "change name of sheet : " & new_ws.name & _ " manually after macro ready. sheet name" & _ " typed in exists or use characters" & _ " not allowed in sheet name." err.clear end if on error goto 0 end if 'paste data new worksheet. new_ws.range("a1") .pastespecial xlpastecolumnwidths .pastespecial xlpastevaluesandnumberformats .select application.cutcopymode = false end application.screenupdating = false 'if did not create table, have option copy formats. if activecellintable = false application.goto acell copyformats = msgbox("do want copy formatting?", _ vbokcancel + vbexclamation, "copy new worksheet") if copyformats = vbok acell.listobject.range.copy new_ws.range("a1") .pastespecial xlpasteformats application.cutcopymode = false end end if end if 'select new worksheet if not active. application.goto new_ws.range("a1") application .screenupdating = true .enableevents = true end 'now we're ready save our new file excel format defaultfilename = activeworkbook.name user = environ("userprofile") 'marker getfilename: return if need new filename getfilename: chdir user & "\desktop" filesavename = application.getsaveasfilename(defaultfilename & ".csv", "comma delimited format (*.csv), *.csv") if filesavename <> "false" 'error handling 'file exists , user clicks 'no' on error resume next activeworkbook.saveas filename:=filesavename, fileformat:=xlcsv, readonlyrecommended:=true, createbackup:=false, conflictresolution:=xluserresolution if err.number = 1004 'offer user 2 options: try different filename or cancel entire export retrysave = msgbox(err.description, vbretrycancel, "error creating file") if retrysave = vbretry 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
update:
in response shagans concern. parameter list on line 1 intended set macro such:
sub exportvisibleascsv call exportlistortable(newbook:=true, willnamesheet:=false, ascsv:=true, visibleonly:=true) end sub
updating example code available:
ok looking @ code posted, see bool named visibleonly don't see gets set. ability logic reach usedrange.copy entirely depends on being set false. comment above acell.listobject.range.copy indicates if reach statement copying visible cells. in order copy hidden cells, visibleonly need set false (bypassing rest of ccount stuff). interested in knowing how bool set , checking see value set when running code.
update 2:
you need set value of visibleonly boolean somehow.
here's code edited creates message box allows user "yes" or "no" "do want copy hidden data too?" answer dictate value of visibleonly in turn dictates flow enter.
in addition that, assumption acell.listobject.range.copy copy visible cells appears have been incorrect. instead being replaced specialcell type visible cells.
finally, vbyesno not return boolean value. instead returns vbyes or vbno vb type enumerators (value 6 , 7 respectively). setting bool value of vbyesno return true (as value exists , evaluates iferror).
so changed bit checks yes/no condition on userchoice (which no longer bool).
here's code:
dim acell, data range dim ccount long dim activecellintable boolean dim copyformats, retrysave variant dim sheetname, user, defaultfilename, filesavename string 'check see if worksheet or workbook protected. todo may not necessary anymore if activeworkbook.protectstructure = true or activesheet.protectcontents = true msgbox "this macro not work when workbook or worksheet write-protected." exit sub end if 'set reference activecell. can use acell 'point cell, no matter in workbook. set acell = activecell 'test see if acell in table or list. note using acell.listobject, 'do not need know name of table work it. on error resume next activecellintable = (acell.listobject.name <> "") on error goto 0 'todo here select fields export 'if cell in list or table run code. if activecellintable = true copyhidden = msgbox("would copy hidden data also?", vbyesno, "copy hidden data?") if copyhidden = vbyes visibleonly = false elseif copyhidden = vbno visibleonly = true end if application .screenupdating = false .enableevents = false end if visibleonly = true 'test if there more 8192 separate areas. excel supports 'a maximum of 8,192 non-contiguous areas through vba macros , manual. on error resume next acell.listobject.listcolumns(1).range 'todo remove "with" ccount = .specialcells(xlcelltypevisible).areas(1).cells.count end on error goto 0 if ccount = 0 msgbox "there more 8192 individual areas, not possible " & _ "copy visible data new worksheet. tip: sort " & _ "data before apply filter , try macro again.", _ vbokonly, "copy new worksheet" exit sub else 'copy visible cells. acell.listobject.range.specialcells(xlcelltypevisible).copy ' visible cells within table in clipboard end if else 'the user indicated wants copy hidden columns too. msgbox ("you wanted copy hidden columns too?") acell.listobject.range.copy ' table data cells including hidden in clipboard end if else ' msgbox "select cell in list or table before run macro.", _ ' vbokonly, "copy new worksheet" userchoice = msgbox("a table/table protion not selected. want export entire page?", vbyesno) if userchoice = vbno exit sub activesheet.usedrange.copy 'entire sheet range in clipboard (this not accurate) 'exit sub end if
Comments
Post a Comment