有没有能把选取的格式样式转为vba代码的？

Nonenever

有没有能把选取的格式样式转为vba代码的？

就是 选取一定的选区，代码按选取的属性生成格式代码，可以用格式代码直接把新建工作表改成原先设置的样式

自己整了一下，不过有点问题，Excel2003下可行，但在2007下 边框有问题，不知道咋回事，代码没有优化
20190825175643测试.rar (35.33 KB, 下载次数: 1)

2019-8-25 19:41 上传

点击文件名下载附件

Excel2003

Excel2007+

边框有问题

夸不得

录制一段代码,然后循环使用啊

maditate

直接复制粘贴，全部格式全过去了。

夸不得

Nonenever 发表于 2019-8-23 20:26
这种方式格式少了可以，格式多了设置起来比较麻烦。有没有一种简单的方法
按完成后的结果 生成 代码

录制的代码很多是可以删减的,你要用的代码就那么几句,但是你就是不知道你要的是哪几句,所以建议你录制好后,有时间可以逐步调试测试,找出你要的代码,这样运行起来速度也快

Nonenever

里面的代码，附件里也有

1. Sub TESTvba测试用()
   
2.     On Error Resume Next
   
3.     Application.DisplayAlerts = False '  取消了警告提示'
   
4.     Application.ScreenUpdating = False '关闭屏幕刷新
   
5.     Application.Calculation = xlManual '将自动计算改为手工计算。
   
6. '    Dim oWShell
   
7. '    Set oWShell = CreateObject("WScript.Shell")
   
8. '    Dim sValue As String
   
9. '    Dim sKey As String
   
10. '    Dim sVersion As String
    
11. '    sVersion = Excel.Application.Version
    
12. '    '键的名称
    
13. '    sKey = "HKEY_CURRENT_USER\Software\Microsoft\Office" & sVersion & "\Excel\Security"
    
14. '    '信任对vba工程对象模型的访问
    
15. '    sValue = "AccessVBOM"
    
16. '    With oWShell
    
17. '      '关闭对vba工程对象模型的访问
    
18. '      .RegWrite sKey & "" & sValue, 0, "REG_DWORD"
    
19. '       '开启对vba工程对象模型的访问
    
20. '      .RegWrite sKey & "" & sValue, 1, "REG_DWORD"
    
21. '    End With
    
22.    
    
23.     Dim f As String
    
24.     f = ActiveWorkbook.Path & "" & Format(Now, "yyyy-mm-dd-hhmmss") & ".BAS"
    
25.     Open f For Output As #1
    
26.     Print #1, " Attribute VB_Name = ""格式复制" & Format(Now, "yyyymmddhhmmss") & """"
    
27.     Print #1, " Sub 格式复制" & Format(Now, "yyyymmddhhmmss") & "()"
    
28.     Print #1, "Application.DisplayAlerts = False'  取消了警告提示'  "
    
29.     Print #1, "Application.ScreenUpdating=False'关闭屏幕刷新"
    
30.     Print #1, "Application.Calculation = xlManual'将自动计算改为手工计算。"
    
31.     Print #1, "On Error Resume Next"
    
32.     Dim Sel As Range
    
33.     Set Sel = Selection
    
34.     Dim MyText As String
    
35.     Dim 总行数 As Integer
    
36.     Dim 总列数 As Integer
    
37.     Dim 原始开始行 As Integer
    
38.     Dim 原始开始列 As Integer
    
39.     总行数 = Sel.Rows.Count
    
40.     总列数 = Sel.Columns.Count
    
41.     Dim i As Integer
    
42.     原始开始行 = Sel.Row
    
43.     原始开始列 = Sel.Column
    
44.     Print #1, " Dim 开始地址 As String"
    
45.     Print #1, "  开始地址 = Selection.Cells(1, 1).Address"
    
46.     Print #1, " Dim 新设开始行 As Integer"
    
47.     Print #1, " Dim 新设开始列 As Integer"
    
48.     Print #1, "  新设开始行  = Selection.Row "
    
49.     Print #1, "  新设开始列 = Selection.Column  "
    
50.     For i = 1 To 总行数
    
51.         Print #1, "Range(开始地址).Offset(" & i - 1 & " , 0).EntireRow.RowHeight =" & Sel.Cells(1, 1).Offset(i - 1, 0).EntireRow.RowHeight
    
52.     Next i
    
53.     For i = 1 To 总列数
    
54.         Print #1, "Range(开始地址).Offset( 0 ," & i - 1 & " ).EntireColumn.ColumnWidth =" & Cells(Split(Sel.Cells(1, 1).Address, "$")(2), Sel.Cells(1, 1).Column - 1 + i).ColumnWidth
    
55.     Next i
    
56.     Set d = CreateObject("scripting.dictionary")
    
57.     Dim 单元格分组数量 As Integer
    
58.     For Each xCell In Sel '列出所有单元格
    
59.         If xCell.MergeCells Then
    
60.             ad_str = xCell.MergeArea.Address
    
61.             If d.Count > 0 And d.Exists(ad_str) Then
    
62.             Else
    
63.                 d.Add ad_str, xCell.FormulaR1C1
    
64.             End If
    
65.         Else
    
66.             d.Add xCell.Address, xCell.FormulaR1C1
    
67.         End If
    
68.     Next
    
69.     单元格分组数量 = d.Count
    
70.     Dim c()
    
71.     ReDim c(0 To 单元格分组数量 - 1) ' '重新定义数组的大小 ,新设的地址 组
    
72.     a = d.keys
    
73.     b = d.items
    
74.     For i = 0 To 单元格分组数量 - 1
    
75.         If InStr(a(i), ":") > 0 Then
    
76.             c(i) = "Cells(新设开始行 +" & _
    
77.                 (Range(Left(a(i), InStr(a(i), ":") - 1)).Row - 原始开始行) _
    
78.                 & ", 新设开始列 + " & _
    
79.                 (Range(Left(a(i), InStr(a(i), ":") - 1)).Column - 原始开始列) _
    
80.                 & ")" & "," & "Cells(新设开始行 +" & _
    
81.                 (Range(Right(a(i), Len(a(i)) - InStr(a(i), ":"))).Row - 原始开始行) _
    
82.                 & ", 新设开始列 + " & _
    
83.                 (Range(Right(a(i), Len(a(i)) - InStr(a(i), ":"))).Column - 原始开始列) _
    
84.                 & ")"
    
85.         Else
    
86.             c(i) = "Cells(新设开始行 +" & (Range(a(i)).Row - 原始开始行) & ", 新设开始列 + " & (Range(a(i)).Column - 原始开始列) & ")"
    
87.         End If
    
88.     Next i
    
89.     For i = 0 To 单元格分组数量 - 1
    
90.         If InStr(a(i), ":") > 0 Then
    
91.             Print #1, "Range(" & c(i) & ").Merge"
    
92.         End If
    
93.     Next i
    
94.     For i = 0 To 单元格分组数量 - 1
    
95.         If InStr(a(i), ":") > 0 Then
    
96.             Print #1, "Range(" & c(i) & ").Interior.ColorIndex=" & Range(a(i)).Interior.ColorIndex ''填充颜色。
    
97.             Print #1, "Range(" & c(i) & ").Borders(xlEdgeLeft).LineStyle =" & Range(a(i)).Borders(xlEdgeLeft).LineStyle ''//为左边上边框。
    
98.             Print #1, "Range(" & c(i) & ").Borders(xlEdgeLeft).Weight =" & Range(a(i)).Borders(xlEdgeLeft).Weight
    
99.             Print #1, "Range(" & c(i) & ").Borders(xlEdgeLeft).ColorIndex =" & Range(a(i)).Borders(xlEdgeLeft).ColorIndex
    
100.             Print #1, "Range(" & c(i) & ").Borders(xlEdgeTop).LineStyle =" & Range(a(i)).Borders(xlEdgeTop).LineStyle '//为上边上边框。
     
101.             Print #1, "Range(" & c(i) & ").Borders(xlEdgeTop).Weight =" & Range(a(i)).Borders(xlEdgeTop).Weight
     
102.             Print #1, "Range(" & c(i) & ").Borders(xlEdgeTop).ColorIndex =" & Range(a(i)).Borders(xlEdgeTop).ColorIndex
     
103.             Print #1, "Range(" & c(i) & ").Borders(xlEdgeBottom).LineStyle =" & Range(a(i)).Borders(xlEdgeBottom).LineStyle '//为下边上边框。
     
104.             Print #1, "Range(" & c(i) & ").Borders(xlEdgeBottom).Weight =" & Range(a(i)).Borders(xlEdgeBottom).Weight
     
105.             Print #1, "Range(" & c(i) & ").Borders(xlEdgeBottom).ColorIndex =" & Range(a(i)).Borders(xlEdgeBottom).ColorIndex
     
106.             Print #1, "Range(" & c(i) & ").Borders(xlEdgeRight).LineStyle =" & Range(a(i)).Borders(xlEdgeRight).LineStyle '//为右边边上边框。
     
107.             Print #1, "Range(" & c(i) & ").Borders(xlEdgeRight).Weight =" & Range(a(i)).Borders(xlEdgeRight).Weight
     
108.             Print #1, "Range(" & c(i) & ").Borders(xlEdgeRight).ColorIndex =" & Range(a(i)).Borders(xlEdgeRight).ColorIndex
     
109.         Else
     
110.             Print #1, c(i) & ".Interior.ColorIndex=" & Range(a(i)).Interior.ColorIndex ''填充颜色。
     
111.             Print #1, c(i) & ".Borders(xlEdgeLeft).LineStyle =" & Range(a(i)).Borders(xlEdgeLeft).LineStyle  ''//为左边上边框。
     
112.             Print #1, c(i) & ".Borders(xlEdgeLeft).Weight =" & Range(a(i)).Borders(xlEdgeLeft).Weight
     
113.             Print #1, c(i) & ".Borders(xlEdgeLeft).ColorIndex =" & Range(a(i)).Borders(xlEdgeLeft).ColorIndex
     
114.             Print #1, c(i) & ".Borders(xlEdgeTop).LineStyle =" & Range(a(i)).Borders(xlEdgeTop).LineStyle  '//为上边上边框。
     
115.             Print #1, c(i) & ".Borders(xlEdgeTop).Weight =" & Range(a(i)).Borders(xlEdgeTop).Weight
     
116.             Print #1, c(i) & ".Borders(xlEdgeTop).ColorIndex =" & Range(a(i)).Borders(xlEdgeTop).ColorIndex
     
117.             Print #1, c(i) & ".Borders(xlEdgeBottom).LineStyle =" & Range(a(i)).Borders(xlEdgeBottom).LineStyle  '//为下边上边框。
     
118.             Print #1, c(i) & ".Borders(xlEdgeBottom).Weight =" & Range(a(i)).Borders(xlEdgeBottom).Weight
     
119.             Print #1, c(i) & ".Borders(xlEdgeBottom).ColorIndex =" & Range(a(i)).Borders(xlEdgeBottom).ColorIndex
     
120.             Print #1, c(i) & ".Borders(xlEdgeRight).LineStyle =" & Range(a(i)).Borders(xlEdgeRight).LineStyle  '//为右边边上边框。
     
121.             Print #1, c(i) & ".Borders(xlEdgeRight).Weight =" & Range(a(i)).Borders(xlEdgeRight).Weight
     
122.             Print #1, c(i) & ".Borders(xlEdgeRight).ColorIndex =" & Range(a(i)).Borders(xlEdgeRight).ColorIndex
     
123.         End If
     
124.     Next i
     
125.     For i = 0 To 单元格分组数量 - 1
     
126.         If InStr(a(i), ":") > 0 Then
     
127.             If Len(b(i)) > 0 Then
     
128.                 MyText = Replace(b(i), """", """""")
     
129.                 MyText = Replace(MyText, Chr(10), """ & Chr(10) & """)
     
130.                 Print #1, "Range(" & c(i) & ").FormulaR1C1=""" & MyText & """"
     
131.             End If
     
132.             MyText = Replace(Range(a(i)).NumberFormatLocal, """", """""")
     
133.             Print #1, "Range(" & c(i) & ").NumberFormatLocal=""" & MyText & """"
     
134.             Print #1, "Range(" & c(i) & ").Font.Name=""" & Range(a(i)).Font.Name & """"
     
135.             Print #1, "Range(" & c(i) & ").Font.Size=" & Range(a(i)).Font.Size
     
136.             Print #1, "Range(" & c(i) & ").Font.Color =" & Range(a(i)).Font.Color
     
137.             Print #1, "Range(" & c(i) & ").Font.Bold =" & Range(a(i)).Font.Bold
     
138.             Print #1, "Range(" & c(i) & ").Font.Italic  =" & Range(a(i)).Font.Italic
     
139.             Print #1, "Range(" & c(i) & ").HorizontalAlignment=" & Range(a(i)).HorizontalAlignment
     
140.             Print #1, "Range(" & c(i) & ").VerticalAlignment=" & Range(a(i)).VerticalAlignment
     
141.             Print #1, "Range(" & c(i) & ").WrapText=" & Range(a(i)).WrapText
     
142.         Else
     
143.             If Len(b(i)) > 0 Then
     
144.                 MyText = Replace(b(i), """", """""")
     
145.                 MyText = Replace(MyText, Chr(10), """ & Chr(10) & """)
     
146.                 Print #1, c(i) & ".FormulaR1C1=""" & MyText & """"
     
147.             End If
     
148.             MyText = Replace(Range(a(i)).NumberFormatLocal, """", """""")
     
149.             Print #1, c(i) & ".NumberFormatLocal=""" & MyText & """"
     
150.             Print #1, c(i) & ".Font.Name=""" & Range(a(i)).Font.Name & """"
     
151.             Print #1, c(i) & ".Font.Size=" & Range(a(i)).Font.Size
     
152.             Print #1, c(i) & ".Font.Color =" & Range(a(i)).Font.Color
     
153.             Print #1, c(i) & ".Font.Bold =" & Range(a(i)).Font.Bold
     
154.             Print #1, c(i) & ".Font.Italic  =" & Range(a(i)).Font.Italic
     
155.             Print #1, c(i) & ".HorizontalAlignment=" & Range(a(i)).HorizontalAlignment
     
156.             Print #1, c(i) & ".VerticalAlignment=" & Range(a(i)).VerticalAlignment
     
157.             Print #1, c(i) & ".WrapText=" & Range(a(i)).WrapText
     
158.         End If
     
159.     Next i
     
160.     For i = 0 To 单元格分组数量 - 1
     
161.     Next i
     
162.     Print #1, "Application.DisplayAlerts = True'  打开警告提示"
     
163.     Print #1, "Application.ScreenUpdating=True'打开屏幕刷新"
     
164.     Print #1, "Application.Calculation = xlAutomatic'将手工计算改为自动计算。"
     
165.     Print #1, " End Sub"
     
166.     Close #1
     
167.     Application.VBE.ActiveVBProject.VBComponents.Import f '导入格式复制
     
168.       Kill f
     
169.     Application.DisplayAlerts = True '  打开警告提示
     
170.     Application.ScreenUpdating = True '打开屏幕刷新
     
171.     Application.Calculation = xlAutomatic '将手工计算改为自动计算。
     
172. End Sub
     
173. 
     
174. 
     

复制代码