[原创工具] EXCEL自动复制、排版，编号。功能差不多了，无BUG不再更新了。20191003

[原创工具] EXCEL自动复制、排版，编号。功能差不多了，无BUG不再更新了。20191003
下载/围观0 /31人次
请登陆 暂无演示
0.0/0人
3 金币

详情扩展

  • 更新2019-10-09 10:33:15
  • 分类电脑软件
  • 语言中文
  • 分类网络工具
  • 授权免费版

20191003改了点BUG.重新加了分页和页面调整，测试了下没啥问题了，无计划继续更新了。
如果出现溢出错误，系超过了excel最大允许的行数或者列数，改小点即可。
源代码见下面，随意自行修改就好。
没啥技术含量。为感谢置顶加精，后期费了点功夫改进了下罢了，加了点备注，便于和我一样的新手理解阶段。

excel快速编号.zip(17.42 KB, 下载次数: 256)





[Visual Basic] 纯文本查看 复制代码

?

001
002
003
004
005
006
007
008
009
010
011
012
013
014
015
016
017
018
019
020
021
022
023
024
025
026
027
028
029
030
031
032
033
034
035
036
037
038
039
040
041
042
043
044
045
046
047
048
049
050
051
052
053
054
055
056
057
058
059
060
061
062
063
064
065
066
067
068
069
070
071
072
073
074
075
076
077
078
079
080
081
082
083
084
085
086
087
088
089
090
091
092
093
094
095
096
097
098
099
100
101
102
103
104
105
106
'Declare PtrSafe Function timeGetTime Lib "winmm.dll" () As Long
'52pojie.com
    Sub 编号()
    Dim 编号表 As String
    Dim 左上角 As String
    Dim 右下角 As String
    Dim 编号位置 As String
    Dim 输出编号 As String
    Dim 原数据区域 As Range
    Dim 复制到区域 As Range
    Dim 复制区高 As Integer
    Dim 复制区宽 As Integer
    Dim 复制列个数 As Long
    Dim 复制行个数 As Long
    Dim 编号前缀 As String
    Dim 编号后缀 As String
    Dim 编号位数 As Long
    Dim 起始编号 As Long
    Dim 编号步距 As Long
    Dim 编号所在单元格横向 As Integer
    Dim 编号所在单元格纵向 As Integer
    Dim i As Long
    Dim j As Long
    Dim 每页放几行 As Integer
 
    编号表 = Worksheets("批量编号设置").[b1].Value
    左上角 = Worksheets("批量编号设置").[b2].Value
    右下角 = Worksheets("批量编号设置").[b3].Value
    编号位置 = Worksheets("批量编号设置").[b6].Value
    编号前缀 = Worksheets("批量编号设置").[b7].Value
    编号后缀 = Worksheets("批量编号设置").[b8].Value
    编号位数 = Worksheets("批量编号设置").[b9].Value
    起始编号 = Worksheets("批量编号设置").[b10].Value
    编号步距 = Worksheets("批量编号设置").[b11].Value
    每页放几行 = Worksheets("批量编号设置").[D4].Value
    复制区宽 = Worksheets(编号表).Range(Worksheets(编号表).Range(左上角), Worksheets(编号表).Range(右下角)).Columns.Count
    复制区高 = Worksheets(编号表).Range(Worksheets(编号表).Range(左上角), Worksheets(编号表).Range(右下角)).Rows.Count
    编号所在单元格横向 = Worksheets(编号表).Range(编号位置).Column - Worksheets(编号表).Range(左上角).Column + 1
    编号所在单元格纵向 = Worksheets(编号表).Range(编号位置).Row - Worksheets(编号表).Range(左上角).Row + 1
 
 
'删除无用的
'删除右下
    If Worksheets("批量编号设置").[d3] = "" Then
        Worksheets(编号表).Rows(Worksheets(编号表).Range(右下角).Offset(1).Row & ":" & Worksheets(编号表).Rows.Count).Delete
        Worksheets(编号表).Columns(Worksheets(编号表).Range(右下角).Column + 1).Resize(, Worksheets(编号表).Columns.Count - Worksheets(编号表).Range(右下角).Column).Delete
    '删除左上
        If Worksheets(编号表).Range(左上角).Column <> 1 Then
        Worksheets(编号表).Columns(1).Resize(, Worksheets(编号表).Range(左上角).Column - 1).Delete
        End If
        If Worksheets(编号表).Range(左上角).Row <> 1 Then
        Worksheets(编号表).Rows(1).Resize(Worksheets(编号表).Range(左上角).Row - 1).Delete
        End If
    End If
     
    Set 原数据区域 = Worksheets(编号表).Range(Worksheets(编号表).Cells(1, 1), Worksheets(编号表).Cells(复制区高, 复制区宽))
 
'复制数量取整
    Do While Worksheets("批量编号设置").[b5].Value Mod Worksheets("批量编号设置").[b4].Value <> 0
        Worksheets("批量编号设置").[b5].Value = Worksheets("批量编号设置").[b5].Value + 1
    Loop
 
'批量复制
    复制列个数 = Worksheets("批量编号设置").[b4].Value
    复制行个数 = Worksheets("批量编号设置").[b5].Value / Worksheets("批量编号设置").[b4].Value
'复制格式
 
'列复制带列宽
    Worksheets(编号表).Select
    Worksheets(编号表).Columns(1).Resize(, 复制区宽).Copy
    Worksheets(编号表).Columns(1 + 复制区宽).Resize(, (复制列个数 - 1) * 复制区宽).Select
    ActiveSheet.Paste
 
'行复制带行高
    Worksheets(编号表).Select
    Worksheets(编号表).Rows(1).Resize(复制区高).Copy
    Worksheets(编号表).Rows(1 + 复制区高).Resize((复制行个数 - 1) * 复制区高).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
        
'编号 '加分页符
    For j = 0 To 复制行个数 - 1
        For i = 0 To 复制列个数 - 1
        输出编号 = CStr(起始编号)
            Do While Len(输出编号) < 编号位数
            输出编号 = "0" & 输出编号
            Loop
        输出编号 = 编号前缀 & 输出编号 & 编号后缀
        Worksheets(编号表).Cells(j * 复制区高 + 编号所在单元格纵向, i * 复制区宽 + 编号所在单元格横向).Value = 输出编号
        起始编号 = 起始编号 + 编号步距
        Next i
        If (j + 1) Mod 每页放几行 = 0 Then
        Worksheets(编号表).HPageBreaks.Add Before:=Worksheets(编号表).Cells((j + 1) * 复制区高 + 编号所在单元格纵向, 1)
        End If
    Next j
 
'页面居中，列居中
    Worksheets(编号表).PageSetup.FitToPagesWide = 1
    Worksheets(编号表).PageSetup.CenterVertically = True
    Worksheets(编号表).PageSetup.CenterHorizontally = True
    Worksheets(编号表).Select
    Worksheets(编号表).UsedRange.Select
    'Worksheets(编号表).PrintPreview
    'Application.Dialogs(xlDialogPrint).Show
End Sub
'52pojie.com



#原创 #工具 #自动 #复制 #排版
文件下载列表
excel快速编号.zip
0.02 MB 下载

相关推荐

首页 导航 会员 客服
QQ客服 TOP