Sub 表格列宽设置()
	'若干表格，每表7列
	On Error Resume Next
	Dim t As Table
	For Each t In ActiveDocument.Tables
		t.Select
		Selection.Cells.DistributeWidth
		Selection.Columns.PreferredWidthType=wdPreferredWidthPoints
		Selection.Columns(1).PreferredWidth=CentimetersToPoints(3.85)
		Selection.Columns(2).PreferredWidth=CentimetersToPoints(4.66)
		Selection.Columns(3).PreferredWidth=CentimetersToPoints(2.26)
		Selection.Columns(4).PreferredWidth=CentimetersToPoints(1.78)
		Selection.Columns(5).PreferredWidth=CentimetersToPoints(1.41)
		Selection.Columns(6).PreferredWidth=CentimetersToPoints(1.41)
	Next
	Selection.HomeKey Unit:=wdStory
End Sub

Sub 合并()
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set st = Worksheets.Add(before:=Sheets(1))
    st.Name = "合并"
    For Each shet In Sheets:
        If shet.Name <> "合并" Then
            i = st.Range("H" & Rows.Count).End(xlUp).Row + 1
            shet.UsedRange.Copy
            st.Cells(i, 1).PasteSpecial Paste:=xlPasteAll
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "已完成"
End Sub

Sub 合并()
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ' 遍历所有工作表
    For Each ws In ThisWorkbook.Worksheets
        ' 检查工作表中是否有内容
        If ws.UsedRange.Rows.Count > 1 Then
            ' 删除第一行
            ws.Rows(1).Delete
        End If
    Next ws
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "已完成"
End Sub