求大佬帮忙把2楼的代码优化下！！！

mxdaidcc

问题一：复制值和格式，列宽，行高 等等 除了不复制公式

想把  表1  A1 复制到  表2的 A1
表1  A2 B2 复制到  表2的 B1
表1  的   K2 : R(K列最后一个有数值的单元格的那个行)  的 区域    复制到  表2的 A2

求大佬帮帮忙

问题二：把EXCEL 表格里的数据 用

.ActiveDocument.Tables(i).Cell(j + 4, 1).Range = Sheets("基本信息").Cells(w, 11)

这个 复制到 word里时  0.25 会变成  .25    0会消失该怎么解决！！


问题三：0基础学习了2星期左右，附件里 自己凑得代码，运行时间长，而且会 崩溃，大佬帮忙优化下 代码见2楼  代码是我参考论坛然后凑的，其中很多意思不懂，大佬们莫要见怪!!  

mxdaidcc

1. Sub 生成word()
   
2.     Dim 新表名称, 行
   
3.     Dim Word对象 As New Word.Application, 当前路径, 新报表的名字, i, j, q, w
   
4.     Dim Str1, Str2
   
5.     Dim tt  As Single
   
6.     tt = Timer
   
7.     当前路径 = ThisWorkbook.Path
   
8.     最后行号 = Worksheets("基本信息").Range("k65536").End(xlUp).Row
   
9. 
   
10.     新表名称 = Worksheets("基本信息").Cells(2, 1) & "-" & Cells(1, 1)
    
11. 
    
12.      
    
13.     On Error Resume Next
    
14.     If Sheets(新表名称) Is Nothing Then                   '判断新表是否已经存在
    
15.     Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = 新表名称
    
16.     Worksheets("基本信息").Range("A1").Copy Worksheets(新表名称).Range("A1")
    
17.     Worksheets("基本信息").Range("A2,B2").Copy Worksheets(新表名称).Range("A2")
    
18.     Worksheets(新表名称).Range("B2").HorizontalAlignment = xlHAlignLeft
    
19.     Worksheets("基本信息").Range("K2:R" & 最后行号).Copy
    
20.     Worksheets(新表名称).Range("A3").PasteSpecial Paste:=xlPasteValues
    
21.     Worksheets("基本信息").Range("K2:R" & 最后行号).Copy
    
22.     Worksheets(新表名称).Range("A3").PasteSpecial Paste:=xlPasteFormats
    
23.     Else
    
24.         MsgBox "工作表: " & 新表名称 & "已存在."
    
25.     End If
    
26. 
    
27.     FileCopy 当前路径 & "\模版.doc", 当前路径 & "" & 新表名称 & ".doc" '复制模版
    
28.     新报表的名字 = 当前路径 & "" & 新表名称 & ".doc"
    
29.     Worksheets(新表名称).Range("B1") = "报告路径：" & 新报表的名字
    
30.    
    
31.     With Word对象
    
32.         .Documents.Open 新报表的名字
    
33.         .Visible = flase
    
34.         
    
35.         Str1 = "数据1"
    
36.         Str2 = Sheets("基本信息").Cells(1, 2)
    
37.         .Selection.HomeKey Unit:=wdStory '光标置于文件首
    
38.         If .Selection.Find.Execute(Str1) Then '查找到指定字符串
    
39.            .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
    
40.            .Selection.Text = Str2 '替换字符串
    
41.         End If
    
42.         
    
43.         Str1 = "数据2"
    
44.         Str2 = Sheets("基本信息").Cells(2, 1)
    
45.         .Selection.HomeKey Unit:=wdStory '光标置于文件首
    
46.         If .Selection.Find.Execute(Str1) Then '查找到指定字符串
    
47.            .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
    
48.            .Selection.Text = Str2 '替换字符串
    
49.         End If
    
50.         
    
51.       .ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument '设置位置在正文
    
52.       .Selection.WholeStory '全选
    
53.       .Selection.Copy '复制
    
54.       If 最后行号 > 20 Then
    
55.          For i = 1 To (最后行号 - 2) / 18 '复制页
    
56.             .Selection.EndKey Unit:=wdStory '光标置于文件尾
    
57.             .Selection.InsertBreak Type:=wdPageBreak '分页
    
58.             .Selection.PasteAndFormat (wdPasteDefault) '粘贴
    
59.          Next i
    
60.       End If
    
61.       
    
62.     q = (最后行号 - 2) / 18 + 1
    
63.     w = (j + 2) + (i - 1) * 18
    
64.     For i = 1 To q
    
65.         For j = 1 To 18 '填写表格数据
    
66.             .ActiveDocument.Tables(i).Cell(j + 4, 1).Range = Sheets("基本信息").Cells(w, 11)
    
67.             .ActiveDocument.Tables(i).Cell(j + 4, 2).Range = Sheets("基本信息").Cells(w, 12)
    
68.             .ActiveDocument.Tables(i).Cell(j + 4, 3).Range = Sheets("基本信息").Cells(w, 13)
    
69.             .ActiveDocument.Tables(i).Cell(j + 4, 4).Range = Sheets("基本信息").Cells(w, 14)
    
70.             .ActiveDocument.Tables(i).Cell(j + 4, 5).Range = Sheets("基本信息").Cells(w, 15)
    
71.             .ActiveDocument.Tables(i).Cell(j + 4, 6).Range = Sheets("基本信息").Cells(w, 16)
    
72.             .ActiveDocument.Tables(i).Cell(j + 4, 7).Range = Sheets("基本信息").Cells(w, 17)
    
73.             .ActiveDocument.Tables(i).Cell(j + 4, 8).Range = Sheets("基本信息").Cells(w, 18)
    
74.         Next j
    
75.     Next i
    
76.       End With
    
77.       Word对象.Documents.Save
    
78.       Word对象.Quit
    
79.       Word对象.Documents.Open 新报表的名字
    
80.       Set Word对象 = Nothing
    
81.       
    
82. MsgBox "已生成“" & 新报表的名字 & "”！" & vbCrLf & "用时" & Timer - tt & "秒!", 0 + 48 + 256 + 0, "提示："
    
83.    
    
84. End Sub
    

复制代码

skyzxh

分两次，先把值复制过去，再把格式复制过去

mxdaidcc

skyzxh 发表于 2018-10-12 22:40
分两次，先把值复制过去，再把格式复制过去

复制格式的代码是什么

mxdaidcc

顶下，求助

182197315

mxdaidcc 发表于 2018-10-12 23:47
复制格式的代码是什么

录制宏就知道了

mxdaidcc

11111111111111

mxdaidcc

11111111111111111111

mxdaidcc

111111111111111

mxdaidcc

11111111111