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

Question

我是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文档，但棘手的问题是这里：
我希望每个配方有一个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 

正如前面所说，我可以复制标题并将其粘贴到一个字，但难的是选择每个配方的步骤，并把它放入字然后保存字文件放入预定义的目录（保存部分已经完成并正在工作）。

我的想法是将配方名称作为一种排序方式，如果我们仍然处于相同配方或者我们跳到另一个配方。

功能上，它会是这样：

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 

但我有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中单词的一部分，因为我有巨大的diffic解决如何循环进入食谱并为每个食谱保存一个单词文件。

预先感谢您的帮助，

乔纳森

Answer 1

现在不能测试，但你的循环应该看起来有点像：

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 

希望帮助