工作需要，求助大神帮忙修改一下VBA代码，谢谢

烟火孤星泪

Sub 生成效果表()
'Date:2019/3/7 二月初一 Thursday
'标签:word,excel数据导入word
'备注1:
Application.DisplayAlerts = False
ActiveWorkbook.Save
Application.DisplayAlerts = True
Dim arr2(1 To 50 ^ 4, 1 To 2), rng As Range
arr = ActiveWorkbook.ActiveSheet.Range("A1").CurrentRegion
For i = 3 To UBound(arr)
If Len(arr(i, 1)) Then
k = k + 2
arr2(k, 1) = arr(i, 1)
End If
k = k + 1
arr2(k, 1) = arr(i, 2)
arr2(k, 2) = arr(i, 3)
Next
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("效果表").Delete
On Error GoTo 0
With ActiveWorkbook.Worksheets.Add
.Name = "效果表"
With .Range("A1").Resize(k, 2)
.Value = arr2
.EntireColumn.AutoFit
For Each rng In .Resize(k, 1).SpecialCells(xlCellTypeBlanks)
With rng.Offset(1).Resize(1, 2)
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Bold = True
.Font.ColorIndex = 3
.Font.Name = "等线"
.Font.Size = 16
End With
Next
End With
.Range("A1").EntireRow.Delete
.Range("A1").Resize(k - 1, 2).Copy
End With
With CreateObject("Word.Application")
Set Doc = .Documents.Add
Doc.Content.PasteExcelTable False, False, False
Doc.SaveAs2 ActiveWorkbook.Path & "\效果.docx"
Doc.Close True
.Quit
End With
Set Doc = Nothing
Application.DisplayAlerts = True
MsgBox "完成"
End Sub

附件.rar (25.42 KB, 下载次数: 8)

2019-3-14 15:08 上传

点击文件名下载附件

这代码，生成的内容，能否给B列加上换行，麻烦修改一下，谢谢。

wzsy2_mrf

你如果提供附件，问题早解决了。

lsc900707

wzsy2_mrf 发表于 2019-3-13 18:13
你如果提供附件，问题早解决了。

你说的对，没有附件，只能看看。

烟火孤星泪

wzsy2_mrf 发表于 2019-3-13 18:13
你如果提供附件，问题早解决了。

附件已上传，附件里一个是加载宏，一个是数据表格
麻烦帮忙看看，谢谢

烟火孤星泪

lsc900707 发表于 2019-3-13 20:37
你说的对，没有附件，只能看看。

附件已上传，附件里一个是加载宏，一个是数据表格
麻烦帮忙看看，谢谢！！

northwolves

1. End With
   
2. With CreateObject("Word.Application")

复制代码

之前加一行：

1. [b:b].WrapText = True

复制代码

wzsy2_mrf

1. Sub 生成效果表()
   
2. 'Date:2019/3/7 二月初一 Thursday
   
3. '标签:word,excel数据导入word
   
4. '备注1:
   
5. Application.DisplayAlerts = False
   
6. ActiveWorkbook.Save
   
7. Application.DisplayAlerts = True
   
8. Dim arr2(1 To 50 ^ 4, 1 To 2), rng As Range
   
9. arr = ActiveWorkbook.ActiveSheet.Range("A1").CurrentRegion
   
10. For i = 3 To UBound(arr)
    
11.     If Len(arr(i, 1)) Then
    
12.         k = k + 2
    
13.         arr2(k, 1) = arr(i, 1)
    
14.     End If
    
15.     k = k + 1
    
16.     arr2(k, 1) = arr(i, 2)
    
17.     arr2(k, 2) = arr(i, 3)
    
18. Next
    
19. Application.DisplayAlerts = False
    
20. On Error Resume Next
    
21. ActiveWorkbook.Worksheets("效果表").Delete
    
22. With ActiveWorkbook.Worksheets.Add
    
23.     .Name = "效果表"
    
24.     .[b:b].WrapText = True
    
25.     With .Range("A1").Resize(k, 2)
    
26.         .Value = arr2
    
27.         .EntireColumn.AutoFit
    
28.         For Each rng In .Resize(k, 1).SpecialCells(xlCellTypeBlanks)
    
29.              With rng.Offset(1).Resize(1, 2)
    
30.                 .Merge
    
31.                 .HorizontalAlignment = xlCenter
    
32.                 .VerticalAlignment = xlCenter
    
33.                 .Font.Bold = True
    
34.                 .Font.ColorIndex = 3
    
35.                 .Font.Name = "等线"
    
36.                 .Font.Size = 16
    
37.              End With
    
38.         Next
    
39.     End With
    
40.     .Range("A1").EntireRow.Delete
    
41.     .Range("A1").Resize(k - 1, 2).Copy
    
42. End With
    
43. With CreateObject("Word.Application")
    
44.     Set Doc = .Documents.Add
    
45.     Doc.Content.PasteExcelTable False, False, False
    
46.     Doc.SaveAs2 ActiveWorkbook.Path & "\效果.docx"
    
47.     Doc.Close True
    
48.     .Quit
    
49. End With
    
50. Set Doc = Nothing
    
51. Application.DisplayAlerts = True
    
52. MsgBox "完成"
    
53. End Sub
    

复制代码

wzsy2_mrf

  将  On Error GoTo 0
    With ActiveWorkbook.Worksheets.Add
        .Name = "效果表"
        With .Range("A1").Resize(k, 2)
改成：
    On Error GoTo 0
    With ActiveWorkbook.Worksheets.Add
        .[b:b].WrapText = True
        .Name = "效果表"
        With .Range("A1").Resize(k, 2)

烟火孤星泪

wzsy2_mrf 发表于 2019-3-14 21:42

这个代码可以换行，但是换行后，好像整个表格的行高和列高都改变了，麻烦帮忙看看，谢谢！

烟火孤星泪

wzsy2_mrf 发表于 2019-3-14 21:42

不用了，已经解决了，谢谢各位