Excel macro - running through cells on the same level

So I want to run through A1-C200 and paste everything into a Word document. The trouble is, I have two ways of pasting it into Word, but each one has its downfall.

Goal: Copy A1-C200 into Word and keep the column layout, without copying blancs.

Example 1:

The code below copies everything into Word, but runs from A1 -> A200, B1 -> B200, C1 -> C200. Because it reads through my file this way, I lose my column layout. I would prefer a solution for this example, because this code looks clearer to me.

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."
开发者_StackOverflow社区            "Do nothing."
        Else
            " Copy the cell to the destination"
            .Copy
            appWD.Selection.PasteSpecial
        End If
    End With

    Next iRow
Next iCol

Example 2:

The code below copies the correct column layout, but also inserts blancs. So if A1-A5 and A80-A90 are filled in, I will have 75 blancs in my Word document.

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

There's multiple ways to do this, don't know which is the quickest but here's some code I threw together real quick for you. Getting the range all at once in a variant is the fastest way to grab data out of 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

not quite sure I understand the prob ... but here's a stab at it:

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

at this point Col1, Col2, and Col3 contain your text w the blank cells factored out, so now loop over these to print out

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

(note: code typed in freehand with no checking ... )

How about this to sub for your first solution:

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