Excel 宏 - 在同一级别的单元格中运行

Question

所以我想运行 A1-C200 并将所有内容粘贴到 Word 文档中。问题是，我有两种方法可以将它粘贴到 Word 中，但每种方法都有其缺点。

目标：将 A1-C200 复制到 Word 中并保持列布局，不复制空白。

示例 1：

下面的代码将所有内容复制到 Word 中，但从 A1 -> A200、B1 -> B200、C1 -> C200 运行。因为它以这种方式读取我的文件，所以我丢失了列布局。我更喜欢这个例子的解决方案，因为这段代码对我来说看起来更清晰。

iMaxRow = 200

" Loop through columns and rows"
For iCol = 1 To 3
    For iRow = 1 To iMaxRow

    With Worksheets("GreatIdea").Cells(iRow, iCol)
        " Check that cell is not empty."
        If .Value = "" Then
            "Nothing in this cell."
            "Do nothing."
        Else
            " Copy the cell to the destination"
            .Copy
            appWD.Selection.PasteSpecial
        End If
    End With

    Next iRow
Next iCol

示例 2：

下面的代码复制了正确的列布局，但也插入了空白。所以如果 A1-A5 和 A80-A90 都填好了，我的 Word 文档里会有 75 个空白。

a1 = Range("A1").End(xlDown).Address
lastcell = Range("C1").Address
Range(a1, lastcell).Copy
With Range("A1") 
Range(.Cells(1, 1), .End(xlDown).Cells(2, 3)).Copy
End With
Range("A1:C50").Copy
appWD.Selection.PasteSpecial

Answer 1

有多种方法可以做到这一点，不知道哪种方法最快，但这里有一些我为您快速编写的代码。在变体中一次获取所有范围是从 excel 中获取数据的最快方法。

Sub test()

        Dim i As Long, j As Long
        Dim wd As Word.Document
        Dim wdTable As Word.Table
        Dim wks As Excel.Worksheet
        Dim v1 As Variant
        Set wd = GetObject("C:\Documents and Settings\Jon\Desktop\New Microsoft Word Document.doc")

'Get data in array
        Set wks = ActiveSheet
        v1 = wks.UsedRange        

'Create table
        Set wdTable = wd.Tables.Add(Range:=wd.Application.Selection.Range, NumRows:=1, NumColumns:= _
            ubound(v1,2), DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
            wdAutoFitFixed)


        'Place data
        For i = 1 To UBound(v1)
            For j = 1 To UBound(v1, 2)
                If Len(v1(i, j)) > 0 Then
                    'Add row if not enough rows, this can be done before the j loop if
                    'you know the first column is always filled.
                    'You can also do an advanced filter in excel if you know that the first
                    'column is filled always and filter for filled cells then just
                    'do a straight copy and paste using r1.specialcells(xlCellTypeVisible).copy 
                    'If you know the rows ahead of time when you create the table you can create all the rows at once,
                     'which should save time.
                    wd.application.selection
                    If wdTable.Rows.Count < i Then wdTable.Rows.Add
                    wdTable.Cell(i, j).Range.Text = v1(i, j)
                End If
            Next j
        Next i

        Set wks = Nothing: Set wd = Nothing: Set v1 = Nothing
    End Sub

Answer 2

不太确定我是否理解这个问题......但这里有一个尝试：

dim rg200x3 as range: set rg200x3 = range("a1:c200")

dim Col1 as new collection
dim Col2 as new collection
dim Col3 as new collection

dim rgRow as new range
dim sText as string
for each rgRow in rg200x3
    sText = trim(rgRow.cells(1,1)): if (sText <> "") call Col1.Add(sText)
    sText = trim(rgRow.cells(1,2)): if (sText <> "") call Col2.Add(sText)
    sText = trim(rgRow.cells(1,3)): if (sText <> "") call Col3.Add(sText)
next rgRow

此时，Col1、Col2 和 Col3 包含您的文本，其中空白单元格被分解出来，所以现在循环这些以打印出来

dim i as long
for i = 1 to 200
    on error resume next  ' (cheap way to avoid checking if index > collection sz)
    debug.print Col1(i) + " | " Col2(i) + " | " + Col3(i)
    on error goto 0
next i

（注意：手写代码没有检查...）

Answer 3

如何替代您的第一个解决方案：

iMaxRow = 200

" Loop through columns and rows"
For iRow = 1 To iMaxRow
  For iCol = 1 To 3

    With Worksheets("GreatIdea").Cells(iRow, iCol)
      " Check that cell is not empty."
      If .Value = "" Then
          "Nothing in this cell."
          "Do nothing."
      Else
           "Copy the cell to the destination"
          .Copy appWD.Selection.PasteSpecial
      End If
    End With

  Next iCol
Next iRow