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