Импорт и форматирование таблиц из Word в Excel с помощью VBA

Привет, сообщество StackOverflow. Я новичок в кодировании VBA и пытаюсь импортировать данные таблицы из документа Word в Excel.

Количество таблиц в документе Word будет зафиксировано на уровне 5, равно как и количество строк и столбцов в каждой конкретной таблице.

Мне удалось импортировать все данные, но я не могу понять следующий шаг, где я хотел бы отформатировать импортированные данные.

Пожалуйста, посмотрите на вставленные фотографии ниже результата, который я получаю, и результат, который я хотел бы получить.

Вывод, который я получаю

Результат, который я хочу получить

Пожалуйста, найдите код, который я написал ниже:

Sub CommandButton1_Click()
'Declare variables
    Dim wdDoc As Object
    Dim wdFileName As Variant
    Dim tableNo As Integer
    Dim irow As Long
    Dim icolumn As Long
    row_number = 1
    col_number = 1
    
    'Open specific Word-document to import table
    wdFileName = Application.GetOpenFilename("Word File(*.docx), *.docx", , "Select Word File", , False)
    
    If wdFileName = False Then Exit Sub
    
    Set wdDoc = GetObject(wdFileName)
    With wdDoc
        'Count the number of tables
        tableNo = .tables.Count
        If tableNo = 0 Then
            MsgBox "There are no tables in the specified Word Document. Please select the correct Word Document"
        Else
            'Import of text/data in the tables from Word-document to specified range in Excel. Starts with table 1, then 2 and so on
            For i = 1 To 1
                With .tables(i)
                    For icolumn = 1 To .Rows.Count
                        Application.Range("C6:D7").Cells(col_number, 1).Value = WorksheetFunction.Clean(.cell(icolumn, 1).Range.Text)
                        Application.Range("C6:D7").Cells(col_number, 2).Value = WorksheetFunction.Clean(.cell(icolumn, 2).Range.Text)

                        col_number = col_number + 1
                        row_number = row_number + 1
                    Next icolumn
                End With
            Next i
            
            For i = 2 To 2
                With .tables(i)
                    For icolumn = 1 To .Rows.Count
                        Application.Range("C7:D8").Cells(col_number, 1).Value = WorksheetFunction.Clean(.cell(icolumn, 1).Range.Text)
                        Application.Range("C7:D8").Cells(col_number, 2).Value = WorksheetFunction.Clean(.cell(icolumn, 2).Range.Text)

                        col_number = col_number + 1
                        row_number = row_number + 1
                    Next icolumn
                End With
            Next i
            
            For i = 2 To 2
                With .tables(i)
                    For icolumn = 1 To .Rows.Count
                        Application.Range("C8:D9").Cells(col_number, 1).Value = WorksheetFunction.Clean(.cell(icolumn, 3).Range.Text)
                        Application.Range("C8:D9").Cells(col_number, 2).Value = WorksheetFunction.Clean(.cell(icolumn, 4).Range.Text)

                        col_number = col_number + 1
                        row_number = row_number + 1
                    Next icolumn
                End With
            Next i
            
            For i = 3 To 3
                With .tables(i)
                    For icolumn = 1 To .Rows.Count
                        Application.Range("C9:D10").Cells(col_number, 1).Value = WorksheetFunction.Clean(.cell(icolumn, 1).Range.Text)
                        Application.Range("C9:D10").Cells(col_number, 2).Value = WorksheetFunction.Clean(.cell(icolumn, 2).Range.Text)
                        Application.Range("C9:D10").Cells(col_number, 3).Value = WorksheetFunction.Clean(.cell(icolumn, 3).Range.Text)
                        Application.Range("C9:D10").Cells(col_number, 4).Value = WorksheetFunction.Clean(.cell(icolumn, 4).Range.Text)
                        Application.Range("C9:D10").Cells(col_number, 5).Value = WorksheetFunction.Clean(.cell(icolumn, 5).Range.Text)
                        Application.Range("C9:D10").Cells(col_number, 6).Value = WorksheetFunction.Clean(.cell(icolumn, 6).Range.Text)
                        Application.Range("C9:D10").Cells(col_number, 7).Value = WorksheetFunction.Clean(.cell(icolumn, 7).Range.Text)
                        Application.Range("C9:D10").Cells(col_number, 8).Value = WorksheetFunction.Clean(.cell(icolumn, 8).Range.Text)

                        col_number = col_number + 1
                        row_number = row_number + 1
                    Next icolumn
                End With
            Next i
            
            For i = 4 To 4
                With .tables(i)
                    For icolumn = 1 To .Rows.Count
                        Application.Range("C10:D11").Cells(col_number, 1).Value = WorksheetFunction.Clean(.cell(icolumn, 1).Range.Text)
                        Application.Range("C10:D11").Cells(col_number, 2).Value = WorksheetFunction.Clean(.cell(icolumn, 2).Range.Text)

                        col_number = col_number + 1
                        row_number = row_number + 1
                    Next icolumn
                End With
            Next i
            
            For i = 5 To 5
                With .tables(i)
                    For icolumn = 1 To .Rows.Count
                        Application.Range("C11:D12").Cells(col_number, 1).Value = WorksheetFunction.Clean(.cell(icolumn, 1).Range.Text)
                        Application.Range("C11:D12").Cells(col_number, 2).Value = WorksheetFunction.Clean(.cell(icolumn, 2).Range.Text)

                        col_number = col_number + 1
                        row_number = row_number + 1
                    Next icolumn
                End With
            Next i
            
    End If
    End With
End Sub

Я надеюсь, что сообщество может помочь с этим :)

Попробуйте скопировать диапазон таблицы в Word, а затем вставить форматированный текст в Excel, как описано здесь stackoverflow.com/questions/12245525/…

freeflow 09.12.2022 13:12

Привет @freeflow Дело в том, что я не хочу открывать документ Word и просто вставлять таблицы в Excel. Я написал код так, чтобы он работал с кнопкой управления ActiveX, поэтому все, что мне нужно сделать, это выбрать текстовый документ, а затем все будет импортировано в Excel.

zgk915 09.12.2022 13:56

Как правильно указал свободный поток, необходимую информацию можно найти в ответе, данном в связанном вопросе.

Timothy Rylatt 09.12.2022 14:06

Что ж, я не понимаю ваш комментарий, поскольку первое, что вы делаете в опубликованном коде, - это доступ к открытому документу Word. Вам нужно прочитать последнюю часть ссылки, где показано копирование и вставка из Excel в Word. Вы можете игнорировать всю преамбулу в связанном примере, связанную с открытием документа Word, поскольку у вас уже есть открытый документ Word.

freeflow 09.12.2022 14:16

Что такое номер ячейки для заказа на поставку? это С6

CDP1802 09.12.2022 14:50
Преобразование HTML-таблицы в профессиональный документ Excel
Преобразование HTML-таблицы в профессиональный документ Excel
Это самый простой способ создания Excel из HTML-таблицы.
Импорт excel в laravel в базу данных
Импорт excel в laravel в базу данных
Здравствуйте, дорогой читатель, в этой статье я расскажу практическим и быстрым способом, как импортировать файл Excel в вашу базу данных с помощью...
0
5
55
1
Перейти к ответу Данный вопрос помечен как решенный

Ответы 1

Ответ принят как подходящий

Транспонировать строки и столбцы, кроме таблицы 3.

Sub CommandButton1_Click()

    Dim wdDoc As Object, wdFileName As Variant, tbl As Word.Table
    Dim ws As Worksheet, rng As Range, tableNo As Integer
    Dim r As Long, c As Long
    
    'Open specific Word-document to import table
    wdFileName = Application.GetOpenFilename("Word File(*.docx), *.docx", , "Select Word File", , False)
    
    If wdFileName = False Then Exit Sub
    Set wdDoc = GetObject(wdFileName)
    
    'Count the number of tables
    tableNo = wdDoc.Tables.Count
    If tableNo < 5 Then
        MsgBox "There are not 5 tables in the specified Word Document. Please select the correct Word Document", vbExclamation
        Exit Sub
    End If
    
    Set ws = ActiveSheet 'ThisWorkbook.Sheet(1) '
    For tableNo = 1 To 5
        Set tbl = wdDoc.Tables(tableNo)
        
        Select Case tableNo
            Case 1:
                               
                Set rng = ws.Range("C6") ' top left corner
                ' transpose rows / cols
                For r = 1 To 2
                    For c = 1 To 2
                        rng.Offset(r - 1, c - 1) = WorksheetFunction.Clean(tbl.cell(c, r).Range.Text)
                    Next
                Next
                
            Case 2:
                               
                Set rng = ws.Range("C9")
                ' transpose rows / cols
                For r = 1 To 2
                    For c = 1 To 3
                        rng.Offset(r - 1, c - 1) = WorksheetFunction.Clean(tbl.cell(c, r).Range.Text)
                    Next
                Next
                
                Set rng = ws.Range("C12")
                ' transpose rows / cols
                For r = 3 To 4
                    For c = 1 To 3
                        rng.Offset(r - 3, c - 1) = WorksheetFunction.Clean(tbl.cell(c, r).Range.Text)
                    Next
                Next
                 
            Case 3:
            
                Set rng = ws.Range("C17")
                For r = 1 To tbl.Rows.Count
                    For c = 1 To 8
                        rng.Offset(r - 1, c - 1) = WorksheetFunction.Clean(tbl.cell(r, c).Range.Text)
                    Next
                Next
                
            Case 4:
            
                Set rng = ws.Range("C26")
                ' transpose rows / cols
                For r = 1 To 2
                    For c = 1 To 3
                        rng.Offset(r - 1, c - 1) = WorksheetFunction.Clean(tbl.cell(c, r).Range.Text)
                    Next
                Next
                
            Case 5:
            
                Set rng = ws.Range("C29")
                ' transpose rows / cols
                For r = 1 To 2
                    For c = 1 To 4
                        rng.Offset(r - 1, c - 1) = WorksheetFunction.Clean(tbl.cell(c, r).Range.Text)
                    Next
                Next
                
        End Select
        
    Next
    Set wdDoc = Nothing
    MsgBox "Done", vbInformation

End Sub

Другие вопросы по теме