官方bilibiliWindows破解入门Android逆向入门
【网络诊断修复工具】切换到窄版

吾爱破解 - 52pojie.cn

 找回密码
 注册[Register]

QQ登录

只需一步，快速开始

吾爱破解 - 52pojie.cn»网站 › 【 软件安全 】 › 『原创发布区』 › EXCEL自动复制、排版，编号，填充序列。20200217小更新
12345678910... 80下一页
返回列表 发新帖
查看: 68991|回复: 761
收起左侧

[原创工具] EXCEL自动复制、排版，编号，填充序列。20200217小更新

    [复制链接]
etkane
etkane 发表于 2019-9-26 20:55
本帖最后由 etkane 于 2020-2-17 23:54 编辑

没想到居然有这么多回复，感谢坛友支持，今天下午没事，根据朋友们的反馈，增加更新了几个小功能，
主要更新的就是已有序列排号及多次排号一次完成（比如姓名，学号，考号；或者两个数字排号）
没有详细测试，有问题，请反馈，看到更新，必要可先用老版本。

小修正20200217235320：感谢pzx_240反映的bug。

新版下载如下：
发布版excel快速编号20200217-235345.rar (31.19 KB, 下载次数: 460)

源码如下：
[Visual Basic] 纯文本查看 复制代码
'Declare PtrSafe Function timeGetTime Lib "winmm.dll" () As Long
'52pojie.com
    Sub 编号()
    Dim 编号表 As String, 左上角 As String, 右下角 As String, 编号位置 As String, 输出编号 As String, 原数据区域 As Range, 复制到区域 As Range, 复制区高 As Integer, 复制区宽 As Integer, 复制列个数 As Long, 复制行个数 As Long, 编号前缀 As String, 编号后缀 As String, 编号位数 As Long, 起始编号 As Long, 编号步距 As Long, 编号所在单元格横向 As Integer, 编号所在单元格纵向 As Integer, i As Long, j As Long, 每页放几行 As Integer
    编号表 = Worksheets("批量编号设置").[b1].Value
    左上角 = Worksheets("批量编号设置").[b2].Value
    右下角 = Worksheets("批量编号设置").[b3].Value
    每页放几行 = Worksheets("批量编号设置").[D4].Value
    复制区宽 = Worksheets(编号表).Range(Worksheets(编号表).Range(左上角), Worksheets(编号表).Range(右下角)).Columns.Count
    复制区高 = Worksheets(编号表).Range(Worksheets(编号表).Range(左上角), Worksheets(编号表).Range(右下角)).Rows.Count
    '编号位置 = Worksheets("批量编号设置").[b6].Value
'删除无用的
'删除右下
    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
'复制格式

'列复制带列宽 ,感谢pzx_240反映的bug。
    Worksheets(编号表).Select
        If 复制列个数 > 1 Then
            Worksheets(编号表).Columns(1).Resize(, 复制区宽).Copy
            Worksheets(编号表).Columns(1 + 复制区宽).Resize(, (复制列个数 - 1) * 复制区宽).Select
            ActiveSheet.Paste
        End If

'行复制带行高
    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


'新版
'循环第一层，有多少列编号
Dim m As Long   '列轮询
Dim n As Long   '行轮询
Dim 分页符数量 As Long
分页符数量 = Worksheets("批量编号设置").[b5].Value / Worksheets("批量编号设置").[b4].Value / 每页放几行
    m = 2
     Do While (Worksheets("批量编号设置").Cells(6, m).Value <> "")
        n = 12
        编号位置 = Worksheets("批量编号设置").Cells(6, m).Value
        编号前缀 = Worksheets("批量编号设置").Cells(7, m).Value
        编号后缀 = Worksheets("批量编号设置").Cells(8, m).Value
        编号位数 = Worksheets("批量编号设置").Cells(9, m).Value
        起始编号 = Worksheets("批量编号设置").Cells(10, m).Value
        编号步距 = Worksheets("批量编号设置").Cells(11, m).Value
        编号所在单元格横向 = Worksheets(编号表).Range(编号位置).Column - Worksheets(编号表).Range(左上角).Column + 1
        编号所在单元格纵向 = Worksheets(编号表).Range(编号位置).Row - Worksheets(编号表).Range(左上角).Row + 1
            '判断是否为预设序列
            If (Worksheets("批量编号设置").Cells(10, m) <> "") Then
            '不是预设序列则执行步距编号
                For j = 0 To 复制行个数 - 1
                    For i = 0 To 复制列个数 - 1
                        输出编号 = CStr(起始编号)
                                Do While Len(输出编号) < 编号位数
                                输出编号 = "0" & 输出编号
                                Loop
                        输出编号 = 编号前缀 & 输出编号 & 编号后缀
                        Worksheets(编号表).Cells(j * 复制区高 + 编号所在单元格纵向, i * 复制区宽 + 编号所在单元格横向).Value = 输出编号
                        起始编号 = 起始编号 + 编号步距
                    Next i

                Next j
            Else
            '是预设序列则按预设序列编号，留空的留空，有多少数据用多少，
            '拍号可能有很多，既然序列就不加判断了
            '如果编号位数不为空，则自动补充0
                For j = 0 To 复制行个数 - 1
                    For i = 0 To 复制列个数 - 1
                        输出编号 = Worksheets("批量编号设置").Cells(n, m)
                            If (Not (IsEmpty(Cells(9, 2)))) Then
                                Do While Len(输出编号) < 编号位数
                                输出编号 = "0" & 输出编号
                                Loop
                            End If
                        输出编号 = 编号前缀 & 输出编号 & 编号后缀
                        Worksheets(编号表).Cells(j * 复制区高 + 编号所在单元格纵向, i * 复制区宽 + 编号所在单元格横向).Value = 输出编号
                        n = n + 1
                    Next i
                Next j
           End If
        m = m + 1
    Loop
'插分页符

 For i = 1 To 分页符数量
    Worksheets(编号表).HPageBreaks.Add Before:=Worksheets(编号表).Cells((i) * 复制区高 * 每页放几行 + 1, 1)
 Next i

'
'    If (j + 1) Mod 每页放几行 = 0 Then
'        Worksheets(编号表).HPageBreaks.Add Before:=Worksheets(编号表).Cells((j + 1) * 复制区高 + 编号所在单元格纵向, 1)
'    End If
    
    

'页面居中，列居中
    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
'更新于：20200217 by etkane
'https://www.52pojie.cn/thread-1029960-1-1.html


截图如下：

微信截图_20200217182834.png
微信截图_20200217183049.png
微信截图_20200217183312.png





以下为历史内容，如新版反馈无问题，则删除，以节省空间。


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

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

微信截图_20191003164544.png

微信截图_20190930140326.png

[Visual Basic] 纯文本查看 复制代码
'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
微信截图_20190930140133.png

excel快速编号（52pojie.com）.rar

20.89 KB, 下载次数: 1511, 下载积分: 吾爱币 -2 CB

发布版excel快速编号20200217.rar

29.62 KB, 下载次数: 74, 下载积分: 吾爱币 -2 CB

免费评分

参与人数 141吾爱币 +126 热心值 +124 收起 理由
一零八八 + 1 + 1 复杂的可以用康虎云报表
alex178 + 1 + 1 热心回复！
leiting110 + 1 用心讨论，共获提升！
yxxxing + 1 鼓励转贴优秀软件安全工具和文档！
tanpan + 1 谢谢@Thanks！
genemiaki + 1 + 1 过年时候就是用你这个给劳务人员做的水果卡！赞！
loveql26 + 1 + 1 我很赞同！
yuzc + 1 + 1 谢谢@Thanks！
Night_月殇 + 1 + 1 谢谢@Thanks！
saully + 1 + 1 我很赞同！
knightlai + 1 + 1 鼓励转贴优秀软件安全工具和文档！
Blueyes + 1 + 1 谢谢@Thanks！
老武 + 1 + 1 热心回复！
hezi112 + 1 + 1 谢谢@Thanks！
王星星 + 1 + 1 热心回复！
侞淉想菍 + 1 我很赞同！
xiaolitao + 1 谢谢@Thanks！
pzx_240 + 1 有意思，不过貌似纵向份数不能填1？感谢分享！
虚生之忧 + 1 + 1 谢谢@Thanks！
pandawei1 + 1 + 1 我很赞同！
yang15540400303 + 1 我很赞同！
TiuNX + 1 + 1 感谢发布原创作品，吾爱破解论坛因你更精彩！
biseshadow + 1 + 1 我很赞同！
lhwx + 1 + 1 谢谢@Thanks！
fishing112 + 1 + 1 谢谢@Thanks！
yefeng007520 + 1 + 1 谢谢@Thanks！
泡泡糸 + 1 + 1 热心回复！
lxlx5602 + 1 + 1 谢谢@Thanks！
snccwt + 1 + 1 热心回复！
yuren008 + 1 + 1 我很赞同！
lazy0lazy + 1 谢谢@Thanks！
wa774779 + 1 + 1 谢谢@Thanks！
小满集藏 + 1 我很赞同！
liboing + 1 + 1 谢谢@Thanks！
情深何用 + 1 + 1 热心回复！
坐看风云变 + 1 + 1 感谢您的宝贵建议，我们会努力争取做得更好！
jawy + 1 + 1 谢谢@Thanks！
zeeblee + 1 + 1 谢谢@Thanks！
lhglmy + 1 + 1 谢谢@Thanks！
yk2575173948 + 1 + 1 热心回复！
zf616545 + 1 + 1 谢谢@Thanks！
jljluping + 1 + 1 虽然不知道哪里能用到，下载了备用，谢谢楼主了！
BUCK队长 + 1 + 1 谢谢@Thanks！
10142028 + 1 谢谢@Thanks！
poco52pojie + 1 + 1 谢谢@Thanks！
38342175 + 1 + 1 我很赞同！
181035970 + 1 我很赞同！
lan10897110 + 1 + 1 我很赞同！
gxsky + 1 虽然没看明白怎么用，但必须支持
zhengwenyi + 1 + 1 谢谢@Thanks！
yhxing + 1 用心讨论，共获提升！
beew + 1 我很赞同！
z_jing + 1 + 1 谢谢@Thanks！
黑色天堂 + 1 + 1 虽然用不上
bamuyu + 1 + 1 谢谢@Thanks！
prettysoul + 1 + 1 谢谢@Thanks！
一切为心造 + 1 + 1 谢谢@Thanks！
lsw8866 + 1 + 1 谢谢@Thanks！
shangwang + 1 + 1 谢谢@Thanks！
fairuza + 1 + 1 鼓励转贴优秀软件安全工具和文档！
46490050 + 1 感谢发布原创作品，吾爱破解论坛因你更精彩！
cdmir3 + 1 + 1 我很赞同！
QAQ难搞哦 + 1 + 1 热心回复！
hacolamatata + 1 + 1 谢谢@Thanks！
火鹤花 + 1 + 1 谢谢@Thanks！
蝉心 + 1 我很赞同！
hai0079 + 1 我很赞同！
月满西楼1985 + 1 谢谢@Thanks！
lwaideingwo + 1 + 1 谢谢@Thanks！
茶城兄弟 + 1 + 1 鼓励转贴优秀软件安全工具和文档！
wencnet + 1 + 1 谢谢@Thanks！
jusir7 + 1 + 1 热心回复！
huicopy + 1 我很赞同！
km00 + 1 + 1 谢谢@Thanks！
新寒武纪 + 1 谢谢@Thanks！
jimmyyq + 1 + 1 感谢发布原创作品，吾爱破解论坛因你更精彩！
wzsgxd + 1 谢谢@Thanks！
衣柜里的阎罗王 + 1 + 1 热心回复！
瀚海驰名 + 1 + 1 用心讨论，共获提升！
wwjw + 1 高质量资源，感谢分享
阿宝到处晃 + 1 + 1 谢谢@Thanks！
senlinv + 1 + 1 热心回复！
xue81207 + 1 + 1 谢谢@Thanks！
wa998 + 1 + 1 热心回复！
qdlitiger + 1 + 1 谢谢@Thanks！
xbxbxbxb + 1 + 1 谢谢@Thanks！
Kanye + 1 + 1 热心回复！
小皮新手学习 + 1 + 1 谢谢@Thanks！
yanguichao + 1 + 1 这种与办公相关的软件，有用没用也要评分。
chao8709 + 1 + 1 热心回复！
abobojing + 1 实用的一笔，谢谢了
放嗳自由 + 1 + 1 谢谢@Thanks！
陈宏毅 + 1 谢谢@Thanks！
东木家长弓 + 1 我很赞同！
izchoo + 1 谢谢@Thanks！
wewewen + 1 感谢发布原创作品，吾爱破解论坛因你更精彩！
lzy199509 + 1 + 1 我很赞同！
saminsam + 1 + 1 谢谢@Thanks！
vee1012 + 1 + 1 谢谢@Thanks！
七个涨停一倍 + 1 谢谢@Thanks！

查看全部评分

本帖被以下淘专辑推荐:

发帖前要善用【论坛搜索】功能，那里可能会有你要找的答案或者已经有人发布过相同内容了，请勿重复发帖。
回复

举报

淡蓝色冷风
淡蓝色冷风 发表于 2019-9-26 21:51
我缺的是VBA工具吗  
缺的是媳妇
【吾爱破解论坛总版规】 - [让你充分了解吾爱破解论坛行为规则]
回复 支持 13

举报

zakigenius
zakigenius 发表于 2019-9-26 22:31
吾爱破解论坛没有任何官方QQ群，禁止留联系方式，禁止任何商业交易。
太厉害了!!!我在EXCELHOME找了半天。。
如何升级？如何获得积分？积分对应解释说明！
回复 支持 1

举报

cqcbc
cqcbc 发表于 2019-9-26 21:04
《站点帮助文档》有什么问题来这里看看吧，这里有你想知道的内容！
不错，用了一下。
呼吁大家发布原创作品添加吾爱破解论坛标识！
回复 支持

举报

wjpfywyj
wjpfywyj 发表于 2019-9-26 21:36
下载试用，谢谢！
如何快速判断一个文件是否为病毒！
回复 支持

举报

浣溪沙
头像被屏蔽
浣溪沙 发表于 2019-9-26 22:39
提示: 作者被禁止或删除 内容自动屏蔽
回复 支持

举报

热血最强
热血最强 发表于 2019-9-27 00:19
不发一下成品图看一下哦
回复 支持

举报

唐甘甜
唐甘甜 发表于 2019-9-27 02:26
看看怎么样
回复 支持

举报

shaokui123
shaokui123 发表于 2019-9-27 16:15
具体干啥用的
没有通俗易懂说明吗
回复 支持

举报

jnez112358
jnez112358 发表于 2019-9-27 16:34
只有自己试了，没看懂什么
回复 支持

举报

下一页 »
12345678910... 80下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册[Register]

本版积分规则


免责声明：
吾爱破解所发布的一切破解补丁、注册机和注册信息及软件的解密分析文章仅限用于学习和研究目的；不得将上述内容用于商业或者非法用途，否则，一切后果请用户自负。本站信息来自网络，版权争议与本站无关。您必须在下载后的24个小时之内，从您的电脑中彻底删除上述内容。如果您喜欢该程序，请支持正版软件，购买注册，得到更好的正版服务。如有侵权请邮件与我们联系处理。

Mail To:Service@52pojie.cn

返回列表

RSS订阅|小黑屋|处罚记录|联系我们|吾爱破解 - LCG - LSG ( 京ICP备16042023号 | 京公网安备 11010502030087号 )

GMT+8, 2024-11-25 09:31

Powered by Discuz!

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表