Range для нескольких ячеек не работает в VBA

Question

Я пытаюсь получить доступ к нескольким клеткам одновременно следующим образом:

Set rng = Worksheets("dts").Range("A3,C3:D3,G8,I8:J8,G9,I9:J9,G21,I21:J21,G30,I30:J30,G39,I39:J39") 

Когда я rangetoHTML следующим образом:

rangetoHTML(rng) 

Function rangetoHTML(rng As Range) 
' Changed by Ron de Bruin 28-Oct-2006 
' Working in Office 2000-2013 
    Dim fso As Object 
    Dim ts As Object 
    Dim TempFile As String 
    Dim TempWB As Workbook 

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm" 

    'Copy the range and create a new workbook to past the data in 
    rng.Copy 
    Set TempWB = Workbooks.Add(1) 
    With TempWB.Sheets(1) 
     .Cells(1).PasteSpecial Paste:=8 
     .Cells(1).PasteSpecial xlPasteValues, , False, False 
     .Cells(1).PasteSpecial xlPasteFormats, , False, False 
     .Cells(1).Select 
     Application.CutCopyMode = False 
     On Error Resume Next 
     .DrawingObjects.Visible = True 
     .DrawingObjects.Delete 
     On Error GoTo 0 
    End With 

    'Publish the sheet to a htm file 
    With TempWB.PublishObjects.Add(_ 
     SourceType:=xlSourceRange, _ 
     Filename:=TempFile, _ 
     Sheet:=TempWB.Sheets(1).Name, _ 
     Source:=TempWB.Sheets(1).UsedRange.Address, _ 
     HtmlType:=xlHtmlStatic) 
     .Publish (True) 
    End With 

    'Read all data from the htm file into RangetoHTML 
    Set fso = CreateObject("Scripting.FileSystemObject") 
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) 
    rangetoHTML = ts.readall 
    ts.Close 
    rangetoHTML = Replace(rangetoHTML, "align=center x:publishsource=", _ 
          "align=left x:publishsource=") 

    'Close TempWB 
    TempWB.Close savechanges:=False 

    'Delete the htm file we used in this function 
    Kill TempFile 

    Set ts = Nothing 
    Set fso = Nothing 
    Set TempWB = Nothing 

End Function 

Он пропускает ГСЧ линии .Copy. Не знаю, почему. Необходимо руководствоваться этим.

Answer 1

вы должны перебрать все ячейки диапазона, чтобы быть скопированными

но Areas свойство Range объекта может помочь, и вы также можете избежать установки tempWb, а просто создать его «на лету» и уволить после того, как он больше не полезная

нравится следующим образом:

Function rangetoHTML(rng As Range) 
' Changed by Ron de Bruin 28-Oct-2006 
' Working in Office 2000-2013 
    Dim fso As Object 
    Dim ts As Object 
    Dim TempFile As String 
    Dim TempWB As Workbook 
    Dim area As Range, cellToOffsetFrom As Range 

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm" 

    'Copy the range and create a new workbook to past the data in 
    With Workbooks.Add(1) '<--| create temp wb 
     With .Sheets(1) 
      Set cellToOffsetFrom = rng.Areas(1).Cells(1, 1) '<--| get the 'rng' upleftmost cell as reference for offsetting all other ones 
      For Each area In rng.Areas '<--| loop through 'Areas' 
       area.Copy '<--| copy single 'Area', i.e. contiguous cells 
       With .Cells(area.Cells(1, 1).Row - cellToOffsetFrom.Row + 1, area.Cells(1, 1).Column - cellToOffsetFrom.Column + 1) '<--| reference proper target cell to paste values 
        .PasteSpecial Paste:=8 
        .PasteSpecial xlPasteValues, , False, False 
        .PasteSpecial xlPasteFormats, , False, False 
       End With 
       Application.CutCopyMode = False 
      Next 
      On Error Resume Next 
      .DrawingObjects.Visible = True 
      .DrawingObjects.Delete 
      On Error GoTo 0 
     End With 

     With .PublishObjects.Add(_ 
      SourceType:=xlSourceRange, _ 
      Filename:=TempFile, _ 
      Sheet:=.Sheets(1).Name, _ 
      Source:=.Sheets(1).UsedRange.Address, _ 
      HtmlType:=xlHtmlStatic) 
      .Publish (True) 
     End With 
    End With 
    ActiveWorkbook.Close savechanges:=False '<--|'Close TempWB 

    'Read all data from the htm file into RangetoHTML 
    Set fso = CreateObject("Scripting.FileSystemObject") 
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) 
    rangetoHTML = ts.readall 
    ts.Close 
    rangetoHTML = Replace(rangetoHTML, "align=center x:publishsource=", _ 
          "align=left x:publishsource=") 

    'Delete the htm file we used in this function 
    Kill TempFile 

    Set ts = Nothing 
    Set fso = Nothing 

End Function