Sub Макрос1() Application.ScreenUpdating = 0 With ActiveSheet.ListObjects(1) If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete [1!O1:O33].AdvancedFilter xlFilterCopy, , [1!M1], True [1!M:M].SpecialCells(2, 23).Copy .HeaderRowRange(1, 1).PasteSpecial xlPasteValues [1!M:M].Clear End With Application.ScreenUpdating = True End Sub
[/vba]
а я пишу [vba]
Код
ActiveSheet.ListObjects(1).DataBodyRange.Clear
[/vba] и у мну ничего не слетает
UPD. [vba]
Код
Sub Макрос1() Application.ScreenUpdating = 0 With ActiveSheet.ListObjects(1) If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete [1!O1:O33].AdvancedFilter xlFilterCopy, , [1!M1], True [1!M:M].SpecialCells(2, 23).Copy .HeaderRowRange(1, 1).PasteSpecial xlPasteValues [1!M:M].Clear End With Application.ScreenUpdating = True End Sub
wwizard, а вы уверены, что эти строки нужно удалить? а если их преобразовать в читабельный вид? [vba]
Код
Sub gg() Dim cell As Range Set cell = Columns(10).Find("\u", , xlValues, xlPart) If Not cell Is Nothing Then With CreateObject("scriptcontrol") .Language = "JScript" Do While Not cell Is Nothing cell.Value = .Eval("unescape(""" & cell & """)") Set cell = Columns(10).FindNext(cell) Loop End With End If End Sub
[/vba]
wwizard, а вы уверены, что эти строки нужно удалить? а если их преобразовать в читабельный вид? [vba]
Код
Sub gg() Dim cell As Range Set cell = Columns(10).Find("\u", , xlValues, xlPart) If Not cell Is Nothing Then With CreateObject("scriptcontrol") .Language = "JScript" Do While Not cell Is Nothing cell.Value = .Eval("unescape(""" & cell & """)") Set cell = Columns(10).FindNext(cell) Loop End With End If End Sub
добавил на всякий случай 2 кнопки 1я - для читабельности, 2я для удаления [vba]
Код
Sub gg() Dim cell As Range Set cell = Columns(10).Find("\u", , xlValues, xlPart) If Not cell Is Nothing Then With CreateObject("scriptcontrol") .Language = "JScript" Do While Not cell Is Nothing cell.Value = .Eval("unescape(""" & cell & """)") Set cell = Columns(10).FindNext(cell) Loop End With End If End Sub Sub ggg() Dim cell As Range, rng As Range, addr$ Set cell = Columns(10).Find("\u", , xlValues, xlPart) If Not cell Is Nothing Then addr = cell.Address Do If rng Is Nothing Then Set rng = cell _ Else Set rng = Union(rng, cell) Set cell = Columns(10).FindNext(cell) Loop While cell.Address <> addr If Not rng Is Nothing Then rng.EntireRow.Delete End If End Sub
[/vba]
добавил на всякий случай 2 кнопки 1я - для читабельности, 2я для удаления [vba]
Код
Sub gg() Dim cell As Range Set cell = Columns(10).Find("\u", , xlValues, xlPart) If Not cell Is Nothing Then With CreateObject("scriptcontrol") .Language = "JScript" Do While Not cell Is Nothing cell.Value = .Eval("unescape(""" & cell & """)") Set cell = Columns(10).FindNext(cell) Loop End With End If End Sub Sub ggg() Dim cell As Range, rng As Range, addr$ Set cell = Columns(10).Find("\u", , xlValues, xlPart) If Not cell Is Nothing Then addr = cell.Address Do If rng Is Nothing Then Set rng = cell _ Else Set rng = Union(rng, cell) Set cell = Columns(10).FindNext(cell) Loop While cell.Address <> addr If Not rng Is Nothing Then rng.EntireRow.Delete End If End Sub
Sub OpenWord() Dim objWrdApp As Object, objWrdDoc As Object
Sret objWdApp = CreateObject("Word.Application") objWrdApp.Visible = True Set objWrdDoc = objWrdApp.Documents.Open("\\sten.local\central\UserData\Морозов\Мои документы\ммм1.docx") With objWrdDoc.Range .Copy .Collapse wdCollapseEnd .Paste End With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}").Clear End Sub
[/vba]или[vba]
Код
Sub OpenWord() Dim objWrdApp As Object, objWrdDoc As Object, R As Object
Sret objWdApp = CreateObject("Word.Application") objWrdApp.Visible = True Set objWrdDoc = objWrdApp.Documents.Open("\\sten.local\central\UserData\Морозов\Мои документы\ммм1.docx") With objWrdDoc.Range Set R = objWrdDoc.Range(.Start, .End - 1) .InsertParagraphAfter .InsertAfter R End With End Sub
[/vba]
[vba]
Код
Sub OpenWord() Dim objWrdApp As Object, objWrdDoc As Object
Sret objWdApp = CreateObject("Word.Application") objWrdApp.Visible = True Set objWrdDoc = objWrdApp.Documents.Open("\\sten.local\central\UserData\Морозов\Мои документы\ммм1.docx") With objWrdDoc.Range .Copy .Collapse wdCollapseEnd .Paste End With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}").Clear End Sub
[/vba]или[vba]
Код
Sub OpenWord() Dim objWrdApp As Object, objWrdDoc As Object, R As Object
Sret objWdApp = CreateObject("Word.Application") objWrdApp.Visible = True Set objWrdDoc = objWrdApp.Documents.Open("\\sten.local\central\UserData\Морозов\Мои документы\ммм1.docx") With objWrdDoc.Range Set R = objWrdDoc.Range(.Start, .End - 1) .InsertParagraphAfter .InsertAfter R End With End Sub
Function GetDate(s$) As Date With CreateObject("VBScript.RegExp") .Global = True .Pattern = "((\d+)|(\W{3})\W*)([ :])+|\W" GetDate = .Replace(s, "$2$3$4") End With End Function
[/vba]
исчо вариант [vba]
Код
Function GetDate(s$) As Date With CreateObject("VBScript.RegExp") .Global = True .Pattern = "((\d+)|(\W{3})\W*)([ :])+|\W" GetDate = .Replace(s, "$2$3$4") End With End Function
Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Private Type uPicDesc Size As Long Type As Long hPic As Long hPal As Long End Type Private Declare Function OpenClipboard _ Lib "user32" ( _ ByVal hwnd As Long _ ) As Long Private Declare Function GetClipboardData _ Lib "user32" ( _ ByVal wFormat As Integer _ ) As Long Private Declare Function CloseClipboard _ Lib "user32" ( _ ) As Long Private Declare Function OleCreatePictureIndirect _ Lib "olepro32.dll" ( _ PicDesc As uPicDesc, _ RefIID As GUID, _ ByVal fPictureOwnsHandle As Long, _ IPic As IPicture _ ) As Long Const CF_BITMAP = 2 Const PICTYPE_BITMAP = 1 Dim strPictureFile As String Public Sub SaveSheetAsImage(sh As Worksheet) Dim IID_IDispatch As GUID Dim uPicinfo As uPicDesc Dim IPic As IPicture Dim hPtr As Long Dim FilePathName$ sh.UsedRange.CopyPicture Appearance:=xlScreen, format:=xlBitmap FilePathName = Application.GetSaveAsFilename("%homepath%\Pictures\", "Рисунок в формате GPEG (*.jpg), *.jpg", , "Сохраненеие изображения", "Сохранить") If FilePathName = "False" Then Exit Sub OpenClipboard 0 hPtr = GetClipboardData(CF_BITMAP) CloseClipboard With IID_IDispatch .Data1 = &H7BF80980 .Data2 = &HBF32 .Data3 = &H101A .Data4(0) = &H8B .Data4(1) = &HBB .Data4(2) = &H0 .Data4(3) = &HAA .Data4(4) = &H0 .Data4(5) = &H30 .Data4(6) = &HC .Data4(7) = &HAB End With With uPicinfo .Size = Len(uPicinfo) .Type = PICTYPE_BITMAP .hPic = hPtr .hPal = 0 End With OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic SavePicture IPic, FilePathName End Sub
[/vba]
в модуле ЭтаКнига [vba]
Код
Sub SaveSheets() Dim sh As Worksheet For Each sh In Sheets SaveSheetAsImage sh Next End Sub
[/vba] [p.s.]правда, наверно, это не совсем то, что нужно, думаю вам поможет виртуальный принтер (например BullZip)
можно как-то так
[vba]
Код
Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Private Type uPicDesc Size As Long Type As Long hPic As Long hPal As Long End Type Private Declare Function OpenClipboard _ Lib "user32" ( _ ByVal hwnd As Long _ ) As Long Private Declare Function GetClipboardData _ Lib "user32" ( _ ByVal wFormat As Integer _ ) As Long Private Declare Function CloseClipboard _ Lib "user32" ( _ ) As Long Private Declare Function OleCreatePictureIndirect _ Lib "olepro32.dll" ( _ PicDesc As uPicDesc, _ RefIID As GUID, _ ByVal fPictureOwnsHandle As Long, _ IPic As IPicture _ ) As Long Const CF_BITMAP = 2 Const PICTYPE_BITMAP = 1 Dim strPictureFile As String Public Sub SaveSheetAsImage(sh As Worksheet) Dim IID_IDispatch As GUID Dim uPicinfo As uPicDesc Dim IPic As IPicture Dim hPtr As Long Dim FilePathName$ sh.UsedRange.CopyPicture Appearance:=xlScreen, format:=xlBitmap FilePathName = Application.GetSaveAsFilename("%homepath%\Pictures\", "Рисунок в формате GPEG (*.jpg), *.jpg", , "Сохраненеие изображения", "Сохранить") If FilePathName = "False" Then Exit Sub OpenClipboard 0 hPtr = GetClipboardData(CF_BITMAP) CloseClipboard With IID_IDispatch .Data1 = &H7BF80980 .Data2 = &HBF32 .Data3 = &H101A .Data4(0) = &H8B .Data4(1) = &HBB .Data4(2) = &H0 .Data4(3) = &HAA .Data4(4) = &H0 .Data4(5) = &H30 .Data4(6) = &HC .Data4(7) = &HAB End With With uPicinfo .Size = Len(uPicinfo) .Type = PICTYPE_BITMAP .hPic = hPtr .hPal = 0 End With OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic SavePicture IPic, FilePathName End Sub
[/vba]
в модуле ЭтаКнига [vba]
Код
Sub SaveSheets() Dim sh As Worksheet For Each sh In Sheets SaveSheetAsImage sh Next End Sub
[/vba] [p.s.]правда, наверно, это не совсем то, что нужно, думаю вам поможет виртуальный принтер (например BullZip) krosav4ig
let aa = Web.Page(Web.Contents("http://minfin.com.ua/currency/nbu/"&DateTime.ToText(Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content]{0}[Column1],"yyyy-MM-dd")&"/")), bb = Table.RemoveRowsWithErrors(Table.AddColumn(aa, "Custom", each [Data][Дата]), {"Custom"}), cc = Table.AddColumn(Table.RemoveColumns(bb,{"Custom"}), "Custom", each Table.ColumnNames([Data])){0}[Custom], dd = Table.SelectColumns(Table.ExpandTableColumn(bb, "Data", cc),cc), ee = Table.ReplaceValue(Table.ReplaceValue(dd,".",Text.Range(Text.From(1/2),1,1),Replacer.ReplaceText,cc),"+ ","+",Replacer.ReplaceText,cc), ff = List.Range(cc,1,1){0}, gg = Table.RenameColumns(Table.TransformColumns(Table.SplitColumn(ee,ff,Splitter.SplitTextByDelimiter("#(lf)"),{ff,"Динамика"}),{},Text.Trim),{{ff, "Курс НБУ"}}), hh = Table.TransformColumnTypes(gg,{{"Курс НБУ", type number}, {"Динамика", type number}, {"За неделю", type number}, {"Дата", type date}, {"Обновляется", type text}, {"КУРС К ГРИВНЕ", type text}}) in hh
let aa = Web.Page(Web.Contents("http://minfin.com.ua/currency/nbu/"&DateTime.ToText(Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content]{0}[Column1],"yyyy-MM-dd")&"/")), bb = Table.RemoveRowsWithErrors(Table.AddColumn(aa, "Custom", each [Data][Дата]), {"Custom"}), cc = Table.AddColumn(Table.RemoveColumns(bb,{"Custom"}), "Custom", each Table.ColumnNames([Data])){0}[Custom], dd = Table.SelectColumns(Table.ExpandTableColumn(bb, "Data", cc),cc), ee = Table.ReplaceValue(Table.ReplaceValue(dd,".",Text.Range(Text.From(1/2),1,1),Replacer.ReplaceText,cc),"+ ","+",Replacer.ReplaceText,cc), ff = List.Range(cc,1,1){0}, gg = Table.RenameColumns(Table.TransformColumns(Table.SplitColumn(ee,ff,Splitter.SplitTextByDelimiter("#(lf)"),{ff,"Динамика"}),{},Text.Trim),{{ff, "Курс НБУ"}}), hh = Table.TransformColumnTypes(gg,{{"Курс НБУ", type number}, {"Динамика", type number}, {"За неделю", type number}, {"Дата", type date}, {"Обновляется", type text}, {"КУРС К ГРИВНЕ", type text}}) in hh