0

我是 VBA 新手，尝试为此解决方案编写一些代码非常困难。任何帮助将不胜感激！

在 MS Word 中，我需要在工作表中查看一个 Excel 工作簿，然后将符合我的条件的数据复制/粘贴到一个两列表中：

从工作表的第 6 行开始，在 D6:M6 范围内查找。如果 D6:M6 为空白，则转到下一行。如果 D6:M6 中的任何单元格有数据，请从 C6 复制数据并将其粘贴到表格的第一行（最好跨两列合并）。然后，从包含数据的列的第 1 行复制数据并将其粘贴到表的下一行（第 1 列）。然后，从包含数据的单元格中复制数据并将其粘贴到第二列。

基本上，如果有数据，表的第一行将来自有数据的行的C列，下一行的第一列将来自有数据的列的第1行，第二行的第2列将来自同一列中包含数据的单元格。

感谢您提供帮助。这是一个示例 Excel 文件的超链接，以及我开始在 MS Word 中编写的仅涵盖第一个产品的非常业余的代码：

Excel 示例文件

   Private Sub useVBinWord()

Dim workBook As workBook
Dim dataInExcel As String


Application.ScreenUpdating = False

Selection.TypeText Text:="Comments:"
Selection.TypeParagraph
Selection.TypeText Text:="Printed:  " & Now
Selection.TypeParagraph

Set workBook = Workbooks.Open("C:\Users....xls", True, True)

ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=100, NumColumns:=2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
With Selection.Tables(1)
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With

dataInExcel = workBook.Worksheets("Top30 Comments").Range("C6").Formula
ActiveDocument.Tables(1).Cell(1, 1).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("D1").Formula
ActiveDocument.Tables(1).Cell(2, 1).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("D6").Formula
ActiveDocument.Tables(1).Cell(2, 2).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("E1").Formula
ActiveDocument.Tables(1).Cell(3, 1).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("E6").Formula
ActiveDocument.Tables(1).Cell(3, 2).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("F1").Formula
ActiveDocument.Tables(1).Cell(4, 1).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("F6").Formula
ActiveDocument.Tables(1).Cell(4, 2).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("G1").Formula
ActiveDocument.Tables(1).Cell(5, 1).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("G6").Formula
ActiveDocument.Tables(1).Cell(5, 2).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("H1").Formula
ActiveDocument.Tables(1).Cell(6, 1).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("H6").Formula
ActiveDocument.Tables(1).Cell(6, 2).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("I1").Formula
ActiveDocument.Tables(1).Cell(7, 1).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("I6").Formula
ActiveDocument.Tables(1).Cell(7, 2).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("J1").Formula
ActiveDocument.Tables(1).Cell(8, 1).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("J6").Formula
ActiveDocument.Tables(1).Cell(8, 2).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("K1").Formula
ActiveDocument.Tables(1).Cell(9, 1).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("K6").Formula
ActiveDocument.Tables(1).Cell(9, 2).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("L1").Formula
ActiveDocument.Tables(1).Cell(10, 1).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("L6").Formula
ActiveDocument.Tables(1).Cell(10, 2).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("M1").Formula
ActiveDocument.Tables(1).Cell(11, 1).Select
Selection.TypeText Text:=dataInExcel

dataInExcel = workBook.Worksheets("Top30 Comments").Range("M6").Formula
ActiveDocument.Tables(1).Cell(11, 2).Select
Selection.TypeText Text:=dataInExcel




workBook.Close True
Set workBook = Nothing
Application.ScreenUpdating = True

End Sub
4

1 回答 1

2

你选择了一个困难的项目开始！这是我几乎完整的解决方案：

Sub ImportTable()

    Dim AppExcel As Excel.Application    '  link to Excel
    Dim ExcelRange As Excel.Range        '  range in worksheet to process
    Dim ExcelData As Variant             '  worksheet data as VBA array
    Dim ExcelHeadings As Variant         '  worksheet headings as VBA array
    Dim FoundCol As Boolean              '  a column found with data ***
    Dim exCol As Integer                 '  Excel column (iterator)
    Dim exRow As Integer                 '  Excel row (iterator)
    Dim wdRow As Integer                 '  Word table row
                                         '  reference to open instance of Excel
    Set AppExcel = GetObject(class:="Excel.Application")
' change this to create an instance and open the file

    Set ExcelRange = AppExcel.ActiveSheet.UsedRange ' the spreadsheet data as a range
'  change this to ensure we have the correct worksheet

' the following reads cells C6 to End into a VBA array (row,column)
    ExcelData = ExcelRange.Offset(5, 2).Resize(ExcelRange.Rows.Count - 6, _
        ExcelRange.Columns.Count - 2)
' the following reads the heading row starting at C1
    ExcelHeadings = ExcelRange.Offset(0, 2).Rows(1)

' assumes we have a blank document in word

    With ActiveDocument.Range

      .InsertAfter "Comments:" & vbCrLf  '  insert your document header
      .InsertAfter "Printed: " & Now & vbCrLf & vbCrLf

    End With

    Selection.EndOf wdStory              '  reposition selection at end

    ActiveDocument.Tables.Add Selection.Range, 1, 2 ' create a 1 x 2 table

    With ActiveDocument.Tables(1)        '  use this table

        .Style = "Table Grid"            '  set the style (copied from your code)
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = False
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = False
        .ApplyStyleRowBands = True
        .ApplyStyleColumnBands = False

' the first row is left blank for you to insert a title
' perhaps you should make this row repeat on each page

        wdRow = 2                        '  we will fill from row 2 which doesn't exist yet
        For exRow = 1 To UBound(ExcelData, 1) Step 3 ' process every 3rd row

            FoundCol = False             '  mark 'not found' ***

            For exCol = 2 To UBound(ExcelData, 2) '  test each column from D

                If Trim(ExcelData(exRow, exCol)) <> "" Then '  if cell not empty

                    If Not FoundCol Then '  first filled column, write header

                        .Rows.Add        '  add row for header
                        .Rows.Add        '  add row for data (avoid problem with merged row)

                        .Rows(wdRow).Cells.Merge '  merge header row

                        .Rows(wdRow).Range.InsertAfter ExcelData(exRow, 1) ' add title from C
                                         '  this keeps the two rows together across page breaks
                        .Rows(wdRow).Range.ParagraphFormat.KeepWithNext = True

                        wdRow = wdRow + 1 ' row added

                        FoundCol = True  '  header written

                    Else

                        .Rows.Add        '  add row for data
                                         '  this keeps the two rows together across page breaks
                        .Rows(wdRow - 1).Range.ParagraphFormat.KeepWithNext = True

                    End If
                                         '  write heading from row 1
                    .Cell(wdRow, 1).Range.InsertAfter ExcelHeadings(1, exCol)
                                         '  write found data
                    .Cell(wdRow, 2).Range.InsertAfter ExcelData(exRow, exCol)

                    wdRow = wdRow + 1    '  row added

                End If

            Next exCol

        Next exRow

    End With

' don't forget to close the instance of Excel

End Sub

阅读评论，我给你留下了一些工作要做！

于 2013-03-29T18:47:53.447 回答