ExcelTip.Net留存知识帖 ---【注：附件之前被网盘供应商清空后，现已修复-现已修复-现已修复为本地下载！】
现在位置：首页 > 我的酷贴 > Word > word表格的操作，合并等

word表格的操作，合并等

作者：绿色风 分类： 时间：2022-08-18 浏览：109
楼主
wqfzqgk		 导出所有表格到一表格.rar

  2. Private Sub Document_Open()
  3. Createmenu'调用创建菜单程序
  4. End Sub

  2. Public Sub Createmenu()'创建菜单
  3. Dim ctrl1 As CommandBarControl'定义
  4. Set myMenuBar = CommandBars.ActiveMenuBar'赋值
  5. Set newMenu = myMenuBar.Controls.Add(Type:=msoControlPopup, Temporary:=True)'增加菜单
  6. newMenu.Caption = "表格合并"
  7. Set ctrl1 = newMenu.CommandBar.Controls.Add(Type:=msoControlButton, ID:=1)
  8. With ctrl1
  9. .Caption = "表格合并"
  10. .TooltipText = "表格合并"
  11. .Style = msoButtonCaption
  12. .OnAction = "表格合并1"
  13. .FaceId = 253
  14. End With
  15. End Sub
  16. Public Sub 表格合并1()
  17. UserForm2.Show
  18. End Sub
  19. Sub 定制表格样式()
  20. Dim i As Table, N As Integer
  21. On Error Resume Next '忽略错误
  22. Application.ScreenUpdating = False '关闭屏幕更新
  23. For Each i In ActiveDocument.Tables '在表格中循环
  24. With i
  25. .Style = "列表型 4" '将所有表格设置为"列表型4"的样式
  26. With .Borders '边框
  27. .InsideLineStyle = wdLineStyleSingle '设置内部边框线条
  28. End With
  29. With .Rows(1).Borders(wdBorderBottom) '第一行的底边框
  30. .LineStyle = wdLineStyleDouble '双线型
  31. .LineWidth = wdLineWidth050pt
  32. .Color = wdColorAutomatic
  33. End With
  34. If .Rows.Count > 1 Then ' 如果表格行数大于1
  35. If Len(.Cell(2, 1).Range) <= 2 Then '如果第二行第一列不为空
  36. With .Rows(2).Shading '设置底纹
  37. .Texture = wdTextureNone '无底底纹
  38. .ForegroundPatternColor = wdColorAutomatic
  39. .BackgroundPatternColor = wdColorGray125
  40. End With
  41. End If
  42. End If
  43. For N = 2 To .Columns.Count '从第二列到最后一列
  44. .Columns(N).Select '单元格对齐方式为中部居中
  45. Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
  46. Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter
  47. Next N
  48. End With
  49. Next i
  50. Application.ScreenUpdating = True
  51. End Sub
  52. Sub 复制表格到新表格中()
  53.     Dim 原表格 As Document'定义
  54.     Dim rngDoc As Range
  55.     Dim tblDoc As Table
  56.     If ActiveDocument.Tables.Count >= 1 Then
  57.         Set 原表格 = ActiveDocument
  58.         Set rngDoc = Documents.Add.Range(Start:=0, End:=0)
  59.         For Each tblDoc In 原表格.Tables'循环表格
  60.             tblDoc.Range.Copy'拷贝表格
  61.             With rngDoc
  62.                 .Paste
  63.                 .Collapse Direction:=wdCollapseEnd
  64.                 .InsertParagraphAfter
  65.                 .Collapse Direction:=wdCollapseEnd
  66.             End With
  67.         Next
  68.     End If
  69. End Sub
  70. Sub 表格排序()
  71. For i = 1 To ActiveDocument.Tables.Count
  72.     ActiveDocument.Tables(i).Sort ExcludeHeader:=True
  73.     Next
  74. End Sub
  75. Sub 表格转换为文本()
  76. For i = 1 To ActiveDocument.Tables.Count
  77. Dim tableTemp As Table
  78. Dim rngTemp As Range
  79. Set tableTemp = ActiveDocument.Tables(1)
  80. Set rngTemp = tableTemp.ConvertToText(Separator:=1)
  81. 'rngTemp.ListFormat.ApplyListTemplate ListTemplate:=ListGalleries(wdBulletGallery).ListTemplates(1)'可以自定义格式
  82. Next
  83. End Sub
  84. Public Sub 合并表格()
  85. Dim adoc As Document
  86. Dim adoca As Document
  87. Set adoc = ActiveDocument
  88. Set adoca = Documents.Add
  89. adoc.Tables(1).Select
  90. Selection.Copy
  91. adoca.Content.Paste
  92. For i = 2 To adoc.Tables.Count
  93. adoc.Tables(i).Select
  94. Selection.Copy
  95. adoca.Tables(1).Select
  96.     Selection.PasteAppendTable'追加表格到表格
  97.   Next
  98. End Sub

  2. Public fils()
  3. Sub 打开文件()
  4.     Dim fd As FileDialog'定义
  5.     Dim cnt As Integer
  6.     Set fd = Application.FileDialog(msoFileDialogFilePicker)'调用文件打开
  7.   With fd
  8.    .Filters.Add "word文件", "*.doc;*.docx", 1'过滤WORD文件
  9.    .FilterIndex = 1'索引第一个
  10.    .AllowMultiSelect = True'多选为真
  11.         If .Show = -1 Then
  12.         Count = 0
  13.             For Each fil In .SelectedItems'所有文件中循环
  14.             Count = Count + 1
  15.             ReDim Preserve fils(1 To Count)
  16.             fils(Count) = fil
  17.             Next
  18.         Else
  19.         End If
  20.     End With
  21.     Set fd = Nothing
  22. End Sub
  23. Sub 表格合并()
  24. On Error Resume Next
  25. Dim biaoshu()
  26. Call 打开文件
  27. For i = 1 To UBound(fils)
  28. Documents.Open fils(i)
  29. For A = 1 To Documents(fils(i)).Tables.Count'调用打开文件中打开的每一个表格
  30. biaohang = biaohang + Documents(fils(i)).Tables(A).Rows.Count'计算表格的行数及列数
  31. biaolie = Documents(fils(i)).Tables(A).Columns.Count
  32. biaohang1 = Documents(fils(i)).Tables(A).Rows.Count
  33. biaolie1 = Documents(fils(i)).Tables(A).Columns.Count
  34. ReDim Preserve biaoshu(1 To biaohang)
  35. For bb = 1 To biaolie1
  36. For aa = 1 To biaohang1
  37. biaoshu(aa + biaohang - biaohang1) = biaoshu(aa + biaohang - biaohang1) & "♀" & Split(Documents(fils(i)).Tables(A).Cell(aa, bb).Range.Text, Chr(13))(0)'把表格中的文字加入到数组中
  38. Next aa
  39. Next bb
  40. Next A
  41. Documents(fils(i)).Close False'关闭当前文件
  42. Next i
  43. On Error Resume Next
  44. Dim newdoc As Document
  45. Dim mytable As Table
  46. Set newdoc = Documents.Add'新建一个文件
  47. 行数 = UBound(biaoshu)
  48. 列数 = biaolie
  49. If 行数 <= 0 Or 列数 <= 0 Then MsgBox "无法建立表格": Exit Sub
  50. Set mytable = newdoc.Tables.Add(Selection.Range, 行数, 列数)'建立一个新的表格
  51. mytable.Select'选择表格
  52. Call 表格线'增加表格线
  53. mytable.AllowAutoFit = True
  54. For i = 1 To 行数
  55. For A = 1 To 列数
  56. mytable.Cell(i, A).Range.Text = Split(biaoshu(i), "♀")(A)'表格中写入文字
  57. Next
  58. Next
  59. End Sub
  60. Sub 表格线()
  61. With Selection
  62.         .Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
  63.         .Borders(wdBorderLeft).LineStyle = Options.DefaultBorderLineStyle
  64.         .Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
  65.         .Borders(wdBorderRight).LineStyle = Options.DefaultBorderLineStyle
  66.        .Borders(wdBorderHorizontal).LineStyle = Options.DefaultBorderLineStyle
  67.         .Borders(wdBorderVertical).LineStyle = Options.DefaultBorderLineStyle
  68.     End With
  69. End Sub
  70. Public Sub 多文档合并表格()
  71. Call 打开文件
  72. Dim adoc As Document
  73. Dim adoca As Document
  74. Set adoca = Documents.Add'增加新文件
  75. adoca.Tables.Add Range:=Selection.Range, NumRows:=1, NumColumns:=9, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
  76. For A = 1 To UBound(fils)
  77. Documents.Open fils(A)
  78. For i = 1 To ActiveDocument.Tables.Count
  79. ActiveDocument.Tables(i).Select'选择表格
  80. Selection.Copy'拷贝
  81. adoca.Tables(1).Select
  82. Selection.PasteAppendTable'追加表格
  83.   Next
  84.   ActiveDocument.Close False'关闭不保存
  85.   Next
  86. End Sub

  2. Private Sub CommandButton1_Click()
  3. On Error GoTo l
  4. Dim i As Table
  5. Label1.Caption = "曾用过的表格样式："
  6. For Each i In ActiveDocument.Tables
  7. With i
  8. .Style = ComboBox1.Value'选择的样式
  9. End With
  10. i.Select
  11. Next
  12. ListBox1.AddItem i.Style
  13. Exit Sub
  14. l:
  15. MsgBox "此种样式不能用于表格中！"
  16. End Sub
  17. Private Sub CommandButton2_Click()
  18. Call 复制表格到新表格中
  19. End Sub
  20. Private Sub CommandButton3_Click()
  21. On Error GoTo l
  22. Dim i As Table
  23. Label1.Caption = "曾用过的表格字体："
  24. For Each i In ActiveDocument.Tables
  25. With i
  26. i.Select
  27. Selection.Font.Name = ComboBox3.Value
  28. End With
  29. ListBox1.AddItem ComboBox3.Text
  30. Exit Sub
  31. Next
  32. l:
  33. MsgBox "此种字体不能用于表格中！"
  34. End Sub
  35. Private Sub CommandButton4_Click()
  36. 表格合并
  37. End Sub

  39. Private Sub CommandButton5_Click()
  40. 合并表格
  41. End Sub
  42. Private Sub CommandButton6_Click()
  43. 表格排序
  44. End Sub
  45. Private Sub CommandButton7_Click()
  46. 表格转换为文本
  47. End Sub
  48. Private Sub CommandButton8_Click()
  49. 定制表格样式
  50. End Sub
  51. Private Sub CommandButton9_Click()
  52. 多文档合并表格
  53. End Sub
  54. Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  55. Dim i As Integer
  56. On Error GoTo l:
  57. Select Case Label1.Caption
  58. Case "曾用过的表格样式："
  59. For i = 0 To ListBox1.ListCount
  60. MsgBox ListBox1.List(i)
  61.         If ListBox1.Selected(i) = True Then
  62.             ComboBox2.AddItem ListBox1.List(i)
  63.         End If
  64.     Next i
  65. Case "曾用过的表格字体："
  66. Exit Sub
  67. End Select
  68. l:
  69. MsgBox "您没有选择，请选择后再双击鼠标！"
  70. End Sub
  71. Private Sub UserForm_Initialize()
  72. Dim afont
  73. For Each st In ActiveDocument.Styles
  74. ComboBox1.AddItem st
  75. Next
  76. ComboBox1.ListIndex = 1
  77. Label1.Caption = "操作项目："
  78. Label2.Caption = "表格样式："
  79. Label3.Caption = "表格字体："
  80. 'Label4.Caption = "表格边框："
  81. For Each afont In FontNames
  82. ComboBox3.AddItem afont
  83. Next
  84. ComboBox3.ListIndex = 1
  85. ComboBox3.Font.Italic = True
  86. ListBox1.MultiSelect = fmMultiSelectSingle
  87. TextBox1.Value = ActiveDocument.Tables.Count
  88. End Sub

  2. Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
  3. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  4. Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  5. Private Declare Function CreateRectRgn Lib "gdi32.dll" (ByVal X As Long, ByVal Y As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  6. Private Declare Function CombineRgn Lib "gdi32.dll" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
  7. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  8. Private Declare Function SetWindowRgn Lib "user32" (ByVal Hwnd As Long, ByVal A As Long, ByVal bRedraw As Long) As Long
  9. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '延迟时间
  10. Dim Hwnd As Long, A As Long, B As Long
  11. Dim flag As Boolean

  13. Private Sub UserForm_Initialize() '去除标题区与边框
  14. TextBox1.Top = Me.Height - 10
  15.     Hwnd = FindWindow("ThunderDFrame", Me.Caption)
  16.     SetWindowLong Hwnd, -16, GetWindowLong(Hwnd, -16) And Not &HC00000
  17. End Sub
  18. Private Sub UserForm_Activate()
  19. 'Application.Visible = False
  20.     For X = 0 To 40 '其修改40可以百叶窗的数量，从而改变每叶的宽度
  21.         A = CreateRectRgn(0, 0, 0, 0)
  22.         For Y = 0 To Me.Width / 40
  23.             B = CreateRectRgn(Y * 40, 0, Y * 40 + X, Me.Height)
  24.             CombineRgn A, A, B, 3
  25.             DeleteObject B
  26.         Next Y
  27.         SetWindowRgn Hwnd, A, True
  28.         DoEvents
  29.         Sleep 30 '延迟时间，用它决定速度
  30.     Next X
  31.     On Error Resume Next
  32.     flag = True
  33.     Do  '开始循环
  34.         DoEvents '转换控制权，从而展现动画效果
  35.         Sleep 30   '以毫秒为单位延时30个单位
  36.         With TextBox1
  37.             .Top = .Top - 1 '将文字框的上边距减1
  38.             If .Top < -(Me.Height) Then .Top = Me.Height '如果消失的窗体框外就返回重新开始
  39.         End With
  40.     Loop While flag
  41. End Sub
  42. Private Sub UserForm_Click() '单击关闭窗体
  43. Unload Me
  44. Application.Visible = True
  45. UserForm1.Show
  46. End Sub
2楼
biaotiger1		 替老大哥补充一个截图。
2012-2-17 20-50-47.jpg
 
3楼
俟人.琳		 学习了，谢谢**

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素， 经与ExcelTip.Net站长Apolloh商议并征得其同意， 现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示， 供有需要的人士查询使用，也慰缅曾经的论坛时代。 所示各个帖子的原作者如对版权有异议， 可与本人沟通提出，或于本站点留言，我们会尽快处理。 在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一

猜您喜欢
评论列表
搜索

鄂ICP备2021011689号-2

powered by emlog pro Theme By 蓝叶

sitemap