Vba 按条件选择Excel单元格，并将其作为图像粘贴到Word中

对于我的软件回归测试，我使用Excel比较参考版本和发布候选版本之间的数值：

回归测试的Excel表格标题：

回归测试的Excel表格正文：

以下vba宏将此数据作为图像复制到Word：

Sub Copy2Word()

Dim ZeilenAnzahl As Integer
Dim MaxBlock As Integer
Dim i As Integer
Dim Copyrange, Zelle As String
ZeilenAnzahl = 80
MaxBlock = 10

Dim objWord, objDoc As Object
ActiveWindow.View = xlNormalView

Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add

For i = 1 To MaxBlock
    Startrow = 1 + (i - 1) * ZeilenAnzahl
    Lastrow = ZeilenAnzahl + (i - 1) * ZeilenAnzahl
    Let Zelle = "A" & Startrow
    If IsEmpty(Range(Zelle).value) = False Then
       Let Copyrange = "A" & Startrow & ":" & "I" & Lastrow
       Range(Copyrange).Select
       Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
       objWord.Visible = True
       objWord.Selection.Paste
       objWord.Selection.TypeParagraph
    End If
Next i

End Sub  

宏将Excel工作表的80行分组为一个图像。我想改变这一点，只选择实际偏差列G大于允许偏差列D的行。宏将收集满足此条件的80行，并将其复制到Word，如果现在发现更多行，则复制其余行

您是如何实现这一点的？

步骤1：您可以添加一个新列，以使用此公式具有一个可选条件，您应将其添加到H列：

=IF(AND(G7<=D7;G7>=-D7);"yes";"no")

步骤3：为确保只复制可见行，请将复制方法替换为xlCellTypeVisible，如下所示：

Selection.SpecialCells(xlCellTypeVisible).Select

让我知道它是否有效

我尝试了另一种解决方案。 我清理了您的数据表，创建了一个只有可选行的新表，并运行以下vba代码编辑sht_数据变量：

Application.DisplayAlerts = False

'sheets
Dim sht_temp As String
Dim sht_data As String
sht_data = "Feuil1" 'TO EDIT
sht_temp = "temp"

'temp sheet
Dim ws As Worksheet
For Each sh In Worksheets
If sh.Name = "temp" Then sh.Delete
Next
Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
ws.Name = sht_temp

'copy header in temp sheet
Worksheets(sht_data).Rows("1:1").Copy
Worksheets(sht_temp).Select
ActiveSheet.Paste

'last row
Dim LastRowData As Integer
Dim LastRowtemp As Integer
LastRowData = Worksheets(sht_data).Cells(Worksheets(sht_data).Rows.Count, "H").End(xlUp).Row

'Copy selectable result in a new sheet
For j = 1 To LastRowData

LastRowtemp = Worksheets(sht_temp).Cells(Worksheets(sht_temp).Rows.Count, "H").End(xlUp).Row + 1


If Worksheets(sht_data).Range("H" & j).Value = "yes" Then
    Worksheets(sht_data).Rows(j & ":" & j).Copy

    Worksheets(sht_temp).Select
    Worksheets(sht_temp).Range("A" & LastRowtemp).Select
    ActiveSheet.Paste

End If

Next j


Dim ZeilenAnzahl As Integer
Dim MaxBlock As Integer
Dim i As Integer
Dim Copyrange, Zelle As String
ZeilenAnzahl = 80
MaxBlock = 10

Worksheets(sht_temp).Activate

Dim objWord, objDoc As Object
ActiveWindow.View = xlNormalView

Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add

For i = 1 To MaxBlock
    Startrow = 1 + (i - 1) * ZeilenAnzahl
    LastRow = ZeilenAnzahl + (i - 1) * ZeilenAnzahl
    Let Zelle = "A" & Startrow
    If IsEmpty(Range(Zelle).Value) = False Then
       Let Copyrange = "A" & Startrow & ":" & "I" & LastRow
       Range(Copyrange).Select
       Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
       objWord.Visible = True
       objWord.Selection.Paste
       objWord.Selection.TypeParagraph
    End If
Next i


Application.DisplayAlerts = True

这条路对我有用

---

让我知道您的情况。

FWIW如果不包括中间的内容，您将无法选择非连续单元格并将其复制为图像。因此，如果要复制为图像，首先需要将符合条件的所有单元格作为单个区域写入工作簿中的某个位置，然后复制。不要引用我的话，但你能隐藏你不想看到的行然后复制吗？如果你理解正确，我必须先执行一些预处理，然后才能选择要导出到Word的图像行。隐藏满足条件的行肯定是一种方法，复制所有不满足条件的行则是另一种方法。尽管如此，我还是在寻找一种解决方案，在宏中完成这项工作。使用Union收集符合条件的所有行，然后unionRange.EntireRow.Hidden=True然后复制整个范围应该有效。Excel给我运行时错误1004，抱怨命令Selection的选定单元格的未连接区域。CopyPicture外观：=xlScreen，格式：=xlPicture。如果我跳过第三步，那么它部分起作用了。部分原因是自动筛选隐藏了我的Excel工作表的标题，我也想将其复制为图像。关于步骤2的一个小提示：为了满足我问题中描述的条件，自动筛选标准应为Criteria1:=否。这种方法也适用于我。我只做了两个小改动：worksheetsht_data.Rows1:19.Copy，如果worksheetsht_data.RangeH&j.value=no，那么。当然我也改变了sht_数据的值。很高兴能帮助你

Application.DisplayAlerts = False

'sheets
Dim sht_temp As String
Dim sht_data As String
sht_data = "Feuil1" 'TO EDIT
sht_temp = "temp"

'temp sheet
Dim ws As Worksheet
For Each sh In Worksheets
If sh.Name = "temp" Then sh.Delete
Next
Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
ws.Name = sht_temp

'copy header in temp sheet
Worksheets(sht_data).Rows("1:1").Copy
Worksheets(sht_temp).Select
ActiveSheet.Paste

'last row
Dim LastRowData As Integer
Dim LastRowtemp As Integer
LastRowData = Worksheets(sht_data).Cells(Worksheets(sht_data).Rows.Count, "H").End(xlUp).Row

'Copy selectable result in a new sheet
For j = 1 To LastRowData

LastRowtemp = Worksheets(sht_temp).Cells(Worksheets(sht_temp).Rows.Count, "H").End(xlUp).Row + 1


If Worksheets(sht_data).Range("H" & j).Value = "yes" Then
    Worksheets(sht_data).Rows(j & ":" & j).Copy

    Worksheets(sht_temp).Select
    Worksheets(sht_temp).Range("A" & LastRowtemp).Select
    ActiveSheet.Paste

End If

Next j


Dim ZeilenAnzahl As Integer
Dim MaxBlock As Integer
Dim i As Integer
Dim Copyrange, Zelle As String
ZeilenAnzahl = 80
MaxBlock = 10

Worksheets(sht_temp).Activate

Dim objWord, objDoc As Object
ActiveWindow.View = xlNormalView

Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add

For i = 1 To MaxBlock
    Startrow = 1 + (i - 1) * ZeilenAnzahl
    LastRow = ZeilenAnzahl + (i - 1) * ZeilenAnzahl
    Let Zelle = "A" & Startrow
    If IsEmpty(Range(Zelle).Value) = False Then
       Let Copyrange = "A" & Startrow & ":" & "I" & LastRow
       Range(Copyrange).Select
       Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
       objWord.Visible = True
       objWord.Selection.Paste
       objWord.Selection.TypeParagraph
    End If
Next i


Application.DisplayAlerts = True