![[原创工具] EXCEL自动复制、排版，编号。功能差不多了，无BUG不再更新了。20191003](/static/img/nopic.jpg)
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).ShowEnd Sub'52pojie.com |
| 文件下载列表 |
|---|
excel快速编号.zip 0.02 MB 下载 |
