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

Question

对于我的软件回归测试，我使用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  

宏将96张Excel表格组合成一张图像。我想改变这种方式，只选择具有实际偏差（“G”列）大于允许偏差（“D”列）的线。宏应收集满足此条件的80行并将其复制到Word或复制其余的行，如果现在找到更多的行。

你怎么会意识到这一点？

Answer 1

step1 ：您可以添加一个新列，使其具有此公式的可选条件，您应将其添加到“H”列：

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

step2 ：在您的vba代码的第一个代码中添加以下代码：

ActiveSheet.Range("A:H").AutoFilter Field:=8, Criteria1:="no"

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

Selection.SpecialCells(xlCellTypeVisible).Select

让我知道它是否有效;）

Answer 2

我尝试了另一种解决方案。 我清理了你的数据表，我创建了一个只有可选行的新工作表，然后运行这个vba代码（编辑sht_data var）：

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

这种方式对我有用。

让我知道你的情况。