Vba 将不同的选定excel范围复制到不同的word文件中

我是vba新手，多年来我一直在互联网上寻找解决我问题的方法。 该项目是我在excel工作表上的一个配方列表，包含不同的步骤，如下所示：

RecipeName    RecipeDescription   Time    Step   StepDescription   Results
Burger        Bread + Meat        Short   Step1  Open Bread        Bread open    
Burger        Bread + Meat        Short   Step2  Cook Meat         Meat cooked    
Soup          Veggie              Short   Step1  Instant soup      Soup done

我很容易定义一个范围并将其粘贴到一个word文档中，但棘手的是：
我希望每个配方有一个单词的文档，首先包含配方名称、说明和时间标题，下面是实际的配方名称、说明和时间。然后是每个步骤的编号、说明和结果。 所以它看起来是这样的：

Burger
------
RecipeName    RecipeDescription   Time
Burger        Bread + Meat        Short

Step1         Open Bread          Bread open
Step2         Cook Meat           Meat cooked

Soup
----
RecipeName    RecipeDescription   Time
Soup          Veggie              Short

Step1         Instant soup        Soup done

如前所述，我可以复制标题并将其粘贴到一个单词中，但困难在于选择每个菜谱的步骤并将其放入word中，然后将word文件保存到预定义的目录中（保存部分已经完成并工作）

我的想法是，如果我们仍然在同一个食谱中，或者如果我们跳转到另一个食谱中，则将食谱名称作为一种排序方式

从功能上讲，它是这样的：

For i = 2 to lastRow
  Open and activate a new word file
  For j = 2 to lastRow      
   If Cells(j,1) = Cells(j+1; 1) Then
   Copy Step, Step Description and Results of row(j)
   Paste into word file
  Next j
   Else
   Copy Step, Step Description and Results of row(i)
   Paste into word file
   Save the word file
   i = j 'So i takes the value of j
Next i

但我和j之间有问题

目前我的代码是这样的，但请原谅我的业余风格：

    Sub ExceltoWord()

    ' 'This part of the code will paste the information into word

    Dim descriptionHeader As Range
    Dim stepHeader As Range
    Dim step As Range
    Dim descriptionTest As Range
    Dim lastRow As Integer
    Dim WordApp As Word.Application
    Dim myDoc As Word.Document
    Dim WordTable As Word.Table

    ' this part of the code will call the rootfolder creation part

    'Call NewFolder

    ' Will Set the title and descrption header
    ThisWorkbook.Sheets("ToWord").Activate
    Set descriptionHeader = Range("A1:C1")
    Set stepHeader = Range("D1:F1")

    'Have the last row stored for later
    lastRow = WorksheetFunction.CountA(Range("A:A"))

    'Optimize Code
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    'Create an Instance of MS Word
    On Error Resume Next

    'Is MS Word already opened?
    Set WordApp = GetObject(class:="Word.Application")

    'Clear the error between errors
    Err.Clear

    'If MS Word is not already open then open MS Word
    If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")

    'Handle if the Word Application is not found
    If Err.Number = 429 Then
        MsgBox "Microsoft Word could not be found, aborting."
        GoTo EndRoutine
    End If

    On Error GoTo 0

    'Make MS Word Visible and Active
    WordApp.Visible = True
    WordApp.Activate

    'Copy Excel Table Range Paste Table into MS Word
    For i = 2 To lastRow
        Set myDoc = WordApp.Documents.Add
        descriptionHeader.Paste
        'Need a part here to paste the actual recipe name, description and time

        For j = 2 To lastRow
        If Cells(i, 1).Content = Cells(i + 1, 1).Content Then
            Cells(i, 6).Activate
            ActiveCell.Offset(0, -2).Range("A1:C1").Select
            With WordApp.Selection
            .TypeText Text:=Cell.Text
            .TypeParagraph
            End With
        Next j
        Else 
            Cells(i, 6).Activate
            ActiveCell.Offset(0, -2).Range("A1:C1").Select
            With WordApp.Selection
            .TypeText Text:=Cell.Text
            .TypeParagraph
            End With

    Next i

EndRoutine:
'Optimize Code
  Application.ScreenUpdating = True
  Application.EnableEvents = True

'Clear The Clipboard
  Application.CutCopyMode = False

End Sub

几周过去了，我一直停留在Excel到word的部分，因为我很难找到如何循环到配方中并为每个配方保存一个word文件

提前感谢您的帮助

---

Jonathan现在无法测试它，但您的循环看起来应该是这样的：

Dim RecipeName As String
Dim DocPath As String
Dim RecipeText As String
DocPath = "C:\.....\"

With ThisWorkbook.Sheets("ToWord")
    For i = 2 To lastRow
        If .Cells(i, 1).Value <> RecipeName Then    'New Recipe
            If Not myDoc Is Nothing Then
                myDoc.Range().Text = RecipeText
                myDoc.SaveAs DocPath & RecipeName & ".doc"
                myDoc.Close False
            End If
            RecipeName = .Cells(i, 1).Value
            Set myDoc = WordApp.Documents.Add
            RecipeText = .Cells(i, 1) & vbCrLf & "-----" & vbCrLf & .Cells(1, 1) & vbTab & .Cells(1, 2) & vbTab & .Cells(1, 3) & vbCrLf
            RecipeText = RecipeText & .Cells(i, 1) & vbTab & .Cells(i, 2) & vbTab & .Cells(i, 3) & vbCrLf & vbCrLf
        End If

        RecipeText = RecipeText & .Cells(i, 4) & vbTab & .Cells(i, 5) & vbTab & .Cells(i, 6) & vbCrLf
    Next i
    myDoc.Range().Text = RecipeText
    myDoc.SaveAs DocPath & RecipeName & ".doc"
    myDoc.Close False

Dim RecipeName作为字符串
将DocPath设置为字符串
将RecipeText设置为字符串
DocPath=“C:\……\”
使用此工作簿。工作表（“ToWord”）
对于i=2到最后一行
如果.Cells（i，1）.Value RecipeName则为“新配方”
如果不是，那么myDoc什么都不是
myDoc.Range（）.Text=RecipeText
myDoc.SaveAs DocPath和RecipeName&“.doc”
myDoc.Close为False
如果结束
RecipeName=.Cells（i，1）.Value
设置myDoc=WordApp.Documents.Add
RecipeText=.Cells（i，1）&vbCrLf&“----”&vbCrLf&.Cells（1，1）&vbTab&.Cells（1，2）&vbTab&.Cells（1，3）&vbCrLf
RecipeText=RecipeText和.Cells（i，1）&vbTab和.Cells（i，2）&vbTab和.Cells（i，3）&vbCrLf和vbCrLf
如果结束
RecipeText=RecipeText和.Cells（i，4）&vbTab和.Cells（i，5）&vbTab和.Cells（i，6）&vbCrLf
接下来我
myDoc.Range（）.Text=RecipeText
myDoc.SaveAs DocPath和RecipeName&“.doc”
myDoc.Close为False

---

希望这有帮助

现在无法测试它，但您的循环应该是这样的：

Dim RecipeName As String
Dim DocPath As String
Dim RecipeText As String
DocPath = "C:\.....\"

With ThisWorkbook.Sheets("ToWord")
    For i = 2 To lastRow
        If .Cells(i, 1).Value <> RecipeName Then    'New Recipe
            If Not myDoc Is Nothing Then
                myDoc.Range().Text = RecipeText
                myDoc.SaveAs DocPath & RecipeName & ".doc"
                myDoc.Close False
            End If
            RecipeName = .Cells(i, 1).Value
            Set myDoc = WordApp.Documents.Add
            RecipeText = .Cells(i, 1) & vbCrLf & "-----" & vbCrLf & .Cells(1, 1) & vbTab & .Cells(1, 2) & vbTab & .Cells(1, 3) & vbCrLf
            RecipeText = RecipeText & .Cells(i, 1) & vbTab & .Cells(i, 2) & vbTab & .Cells(i, 3) & vbCrLf & vbCrLf
        End If

        RecipeText = RecipeText & .Cells(i, 4) & vbTab & .Cells(i, 5) & vbTab & .Cells(i, 6) & vbCrLf
    Next i
    myDoc.Range().Text = RecipeText
    myDoc.SaveAs DocPath & RecipeName & ".doc"
    myDoc.Close False

Dim RecipeName作为字符串
将DocPath设置为字符串
将RecipeText设置为字符串
DocPath=“C:\……\”
使用此工作簿。工作表（“ToWord”）
对于i=2到最后一行
如果.Cells（i，1）.Value RecipeName则为“新配方”
如果不是，那么myDoc什么都不是
myDoc.Range（）.Text=RecipeText
myDoc.SaveAs DocPath和RecipeName&“.doc”
myDoc.Close为False
如果结束
RecipeName=.Cells（i，1）.Value
设置myDoc=WordApp.Documents.Add
RecipeText=.Cells（i，1）&vbCrLf&“----”&vbCrLf&.Cells（1，1）&vbTab&.Cells（1，2）&vbTab&.Cells（1，3）&vbCrLf
RecipeText=RecipeText和.Cells（i，1）&vbTab和.Cells（i，2）&vbTab和.Cells（i，3）&vbCrLf和vbCrLf
如果结束
RecipeText=RecipeText和.Cells（i，4）&vbTab和.Cells（i，5）&vbTab和.Cells（i，6）&vbCrLf
接下来我
myDoc.Range（）.Text=RecipeText
myDoc.SaveAs DocPath和RecipeName&“.doc”
myDoc.Close为False

---

希望这能有所帮助

非常感谢您的回答，我会尝试一下并提供最新结果。Jochen，非常感谢您的回答。它就像一个符咒。我不得不修改表格和vbCrLf，为word文档提供更好的布局，但除此之外，它是完美的。当我尝试将我的条件声明为.Cells（I，1）=.Cells（I+1，1）时，简单的解决方案是将条件设置为不同的，并存储要比较的值。非常简单，但在我看来，这纯粹是天才。非常感谢你的回答。我会尝试一下，并给出最新的结果。乔申，非常感谢你。它就像一个符咒。我不得不修改表格和vbCrLf，为word文档提供更好的布局，但除此之外，它是完美的。当我尝试将我的条件声明为.Cells（I，1）=.Cells（I+1，1）时，简单的解决方案是将条件设置为不同的，并存储要比较的值。很简单，但在我看来是纯粹的天才。