Здравствуйте!  
 
Возникла необходимость скопировать в Word листы всей книги, выполнив прежде с ними некоторые идентичные действия, но, т.к. в Excel должны остаться листы без изменений сделано следующее:    
создается новый лист -> на него копируется таблица -> объединяются ячейки и т.п. -> таблица с нового листа вставляется в Word -> новый лист удаляется -> Next...  
 
Тут возникает проблема: объединенные ячейки копируются не с одного листа, а со всех и получается в Word следующая картина:  
В Лист1 стоит: Наименование 1 -> Документ1 получается: Наименование 1  
В Лист2 стоит: Наименование 2 -> Документ2 получается: Наименование 1Наименование 2  
В Лист3 стоит: Наименование 3 -> Документ3 получается: Наименование 1Наименование 2Наименование 3    
и т.д.  
 
Подскажите, что не так в этом макросе?  
 
Const sDELIM As String = ""  
Dim rCell1 As Range  
Dim sMergeStr1 As String  
StrVal = StrVal & vbLf & NextStr  
 
i = Application.Worksheets.Count  
For iList = 1 To i  
Worksheets(iList).Activate  
                 
Range("A:J").Copy  
Worksheets.Add After:=Worksheets(Worksheets.Count)  
Worksheets(Worksheets.Count).Name = "New"  
Set wb = ActiveWorkbook  
ActiveWorkbook.Sheets("New").Paste  
Selection.Cells(1).Select  
 
S1 = "Наименованин"    
Cells.Find(What:=S1, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _  
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Activate  
I1 = Selection.Column  
J1 = Selection.Row  
Range(Cells(J1 - 2, I1), Cells(J1 + 1, I1)).Select  
With Selection  
   If TypeName(Selection) <> "Range" Then Exit Sub  
   With Selection  
       For Each rCell1 In .Cells  
           sMergeStr1 = sMergeStr1 & sDELIM & rCell1.Text  
       Next rCell1  
       Application.DisplayAlerts = False  
       .Merge Across:=False  
       Application.DisplayAlerts = True  
       .Item(1).Value = Mid(sMergeStr1, 1 + Len(sDELIM))  
   End With  
   .HorizontalAlignment = xlCenter  
   .VerticalAlignment = xlCenter  
End With  
Range(Cells(J1 - 1, I1), Cells(J1 + 1, 10)).Delete Shift:=xlUp  
Selection.Cells(1).Select  
 
Range("A:J").Select  
Selection.Rows.AutoFit  
Selection.Copy  
 
Set wa1 = CreateObject("Word.Application")  
wa1.Visible = True: Set wd1 = wa1.Documents.Add  
wa1.Selection.PasteExcelTable False, False, False  
Application.CutCopyMode = False  
wa1.Run "Макрос1"  
   
Application.DisplayAlerts = False  
wb.Sheets("New").Delete  
Application.DisplayAlerts = True  
 
Next  
 
Заранее спасибо!