代码之家 › 专栏 › 技术社区 › CKE user3026927

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

excel-vba vba excel

-1

CKE user3026927 · 技术社区 · 7 年前

对于我的软件回归测试,我使用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,如果现在找到更多行,则复制其余行。

你是如何认识到这一点的?

2 回复 | 直到 7 年前

1

JC Guidicelli 7 年前

我清理了您的数据表,创建了一个只有可选行的新工作表,并运行了这个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

这条路对我很有效。

让我知道你的情况。

2

1

JC Guidicelli 7 年前

STEP1 :您可以使用此公式添加一个新列,使其具有可选择的条件,您应将其添加到列“h”中:

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

第二步 :在VBA代码的第一个加载项中使用此代码添加筛选器:

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

步骤3 :要确保只复制可见行,请将复制方法替换为XLcellTypeVisible,如下所示:

Selection.SpecialCells(xlCellTypeVisible).Select

让我知道它是否起作用;)