[已解决]急求VBA重新排编号

zhongyong6899

请教高手：如何修改程序使得执行的后程序一班至九班编号按照001、/002………等顺序重新排列？如：一班工作表A5的值应为“003”。详见附件，万分感谢！！！

最佳答案

月排行榜 / 总排行榜

苏子龙

2017-4-19 19:09

Sub test1()
Application.ScreenUpdating = False
Dim bj As Range, hh As Long, sht As Worksheet, wb As String
For Each sht In Worksheets
        If sht.Name <> "全部" Then
            Worksheets("全部").[a1:e1].Copy sht.[a1]
            sht.[a1].CurrentRegion.Offset(1).Clear
            Worksheets("全部").[a2:e2].Copy sht.[a2]
        End If
        Next
hh = 3
wb = Sheet1.Cells(hh, "B")
Do While wb <> ""
    Set bj = Worksheets(wb).Cells(Rows.Count, 1).End(3).Offset(1, 0)
    Sheet1.Cells(hh, "A").Resize(1, 5).Copy bj
    hh = hh + 1
    wb = Sheet1.Cells(hh, "B")
Loop
'b = 0
For Each sht In Worksheets
        With sht
            If .Name <> "全部" Then
                .Columns(2).Delete   '删除第2列
                .Columns(2).ColumnWidth = 20      '设置第二列的宽度
                .Range("A:A,C:C,D:D").ColumnWidth = 15     '设置第一列、第三列的宽度
                x = Array("编辑1", "编辑2", "编辑3", "编辑4", "编辑5", "编辑6", "编辑7", "编辑8", "编辑9")  '表头内容自己编辑
                .[a1].Resize(1, 4) = x(b)
                .Range("A1:D1").Font.Size = 11   '第1行设置11号字体
                .Rows(1).RowHeight = 50       '第1行的行高
               
                With .[a1].CurrentRegion.Offset(1)   '设置下面各行
                    .Font.Size = 10   '10号字体
                    .RowHeight = 30       '行高
                    .WrapText = True        '自动换行
                End With
                .Range(sht.Cells(3, 1), .Cells(.Cells(Rows.Count, 1).End(3).Row, 4)).Sort key1:=.Cells(3, 4), Order1:=xlAscending, Header:=xlNo
                For i = 3 To sht.Cells(Rows.Count, 1).End(3).Row
                    .Cells(i, 1) = "'" & Format(i - 2, "000")
                Next
'                 b = b + 1
            End If
        End With
    Next
'    For Each sht In Worksheets
'    If sht.Name <> "全部" Then
'        sht.Range(sht.Cells(3, 1), sht.Cells(sht.Cells(Rows.Count, 1).End(3).Row, 4)).Sort key1:=sht.Cells(3, 4), Order1:=xlAscending, Header:=xlNo
'
'    End If
'    Next
    Application.ScreenUpdating = True
End Sub
大概就是改成这样

跳转到最佳答案楼层

苏子龙

Sub test1()
Application.ScreenUpdating = False
Dim bj As Range, hh As Long, sht As Worksheet, wb As String
For Each sht In Worksheets
        If sht.Name <> "全部" Then
            Worksheets("全部").[a1:e1].Copy sht.[a1]
            sht.[a1].CurrentRegion.Offset(1).Clear
            Worksheets("全部").[a2:e2].Copy sht.[a2]
        End If
        Next
hh = 3
wb = Sheet1.Cells(hh, "B")
Do While wb <> ""
    Set bj = Worksheets(wb).Cells(Rows.Count, 1).End(3).Offset(1, 0)
    Sheet1.Cells(hh, "A").Resize(1, 5).Copy bj
    hh = hh + 1
    wb = Sheet1.Cells(hh, "B")
Loop
'b = 0
For Each sht In Worksheets
        With sht
            If .Name <> "全部" Then
                .Columns(2).Delete   '删除第2列
                .Columns(2).ColumnWidth = 20      '设置第二列的宽度
                .Range("A:A,C:C,D:D").ColumnWidth = 15     '设置第一列、第三列的宽度
                x = Array("编辑1", "编辑2", "编辑3", "编辑4", "编辑5", "编辑6", "编辑7", "编辑8", "编辑9")  '表头内容自己编辑
                .[a1].Resize(1, 4) = x(b)
                .Range("A1:D1").Font.Size = 11   '第1行设置11号字体
                .Rows(1).RowHeight = 50       '第1行的行高
               
                With .[a1].CurrentRegion.Offset(1)   '设置下面各行
                    .Font.Size = 10   '10号字体
                    .RowHeight = 30       '行高
                    .WrapText = True        '自动换行
                End With
                .Range(sht.Cells(3, 1), .Cells(.Cells(Rows.Count, 1).End(3).Row, 4)).Sort key1:=.Cells(3, 4), Order1:=xlAscending, Header:=xlNo
                For i = 3 To sht.Cells(Rows.Count, 1).End(3).Row
                    .Cells(i, 1) = "'" & Format(i - 2, "000")
                Next
'                 b = b + 1
            End If
        End With
    Next
'    For Each sht In Worksheets
'    If sht.Name <> "全部" Then
'        sht.Range(sht.Cells(3, 1), sht.Cells(sht.Cells(Rows.Count, 1).End(3).Row, 4)).Sort key1:=sht.Cells(3, 4), Order1:=xlAscending, Header:=xlNo
'
'    End If
'    Next
    Application.ScreenUpdating = True
End Sub
大概就是改成这样