0

私は VBA 初心者で、このソリューションのコードを書くのに非常に苦労しています。どんな助けでも大歓迎です！

MS Word 内で、ワークシート全体で 1 つの Excel ワークブックを調べ、基準に適合するデータをコピーして 2 列のテーブルに貼り付ける必要があります。

ワークシートの行 6 から開始し、D6:M6 の範囲内を調べます。D6:M6 が空白の場合は、次の行に進みます。D6:M6 のいずれかのセルにデータがある場合は、C6 からデータをコピーして、表の最初の行に貼り付けます (できれば 2 つの列に結合します)。次に、データがある列の行 1 からデータをコピーし、テーブルの次の行 (1 列目) に貼り付けます。次に、データのあるセルからデータをコピーし、それを 2 列目に貼り付けます。

基本的にデータがある場合、表の1行目はデータのある行のC列、次の行の1列目はデータのある列の1行目、2行目の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 に答える