【原】Excel VBA 批量设置单元格格式/Excel表格拆分神器（更新）

快速浏览

往期合集：【2023年3月】【2023年4月】【2023年5月】【2023年6月】

实用案例：|收费管理系统|中医诊所收费系统|日期控件|简单的收发存|电子发票管理助手|

内容提要

VBA代码，批量设置单元格格式

大家好，我是冷水泡茶，前两天我分享了一款小工具：Excel VBA Excel表格拆分通用版，有朋友试用以后，反映了一些BUG及使用需求，

1、导出身份证号码显示不全

2、可否自动设置列宽

3、在WPS中报错

......

本来以为简单地添加一两句代码就能搞定，哪知越改越多，干脆还是写篇文章记录一下，也作为一个集中回复。

批量设置数字、日期、文本格式，自动列宽

关于身份证号码，如果全部是数字的话，在EXCEL单元格里会被显示成科学记数法的形式，让人看了就头大，解决方法是把单元格设置成文本格式。

于是我就在SaveToExcel过程中添加一条代码，把所有单元格格式都设置成文本：rng.NumberFormat = "@"

当然，我们要先定义一个Range对象rng，大小就是我们要写入的数据区域大小。这样，身份证号显示的问题似乎解决了，但新的问题又来了：

如果把所有单元格都设置成文本，那么数字、日期也都变成了文本，虽然看上去没什么大的区别，但如果需要进一步处理数据的话，可能就有点麻烦。

所以，我们还是希望日期列就是日期格式，数值就是数值格式。那么就继续改吧：

1、在选择工作表的时候，我们把日期列名，数值列名分别添加到数组arrDateColFields，arrNumColFields里（以便SaveToExcel过程中调用）：

 Sub CmbSheets_Change() ...... For i = 1 To lastCol        If IsDate(arr(2, i)) Then   '日期字段            Me.CmbDateColumn.AddItem arr(1, i)            ReDim Preserve arrDateColFields(j)            arrDateColFields(j) = arr(1, i)            j = j + 1        ElseIf IsNumeric(arr(2, i)) And Len(arr(2, i)) < 15 Then   '数值字段            Me.CmbNumberColumn.AddItem arr(1, i)            ReDim Preserve arrNumColFields(k)            arrNumColFields(k) = arr(1, i)            k = k + 1        Else      '除日期、数值字段，其他可供筛选字段            Me.CmbFilterColumn.AddItem (arr(1, i))        End If    Next......end sub

代码解析：

（1）arrDateColFields，arrNumColFields这两个数组我们定义在Userform1模块所有过程之外，作为公众变量。

（2）把字段名添加到数组，我们采用Redim Preserve的方法

（3）数值列增加了一个长度的判断，少于15位。基本上没有这么大的数值，这样就把身份证号排除在数值列之外。

2、在SaveToExcel过程中，设置rng的格式：

Sub SaveToExcel()    Dim rng As Range, col As Range    '原来导出的是word文件，扩展名改一下    fileName = Replace(fileName, ".docx", ".xlsx")    Workbooks.Add    With ActiveWorkbook        If Me.CkbTitle Then            .Sheets(1).Range(Cells(1, 1), Cells(1, UBound(arrTem, 1) + 1)).MergeCells = True            .Sheets(1).Range("A1") = Me.TxbTitle            .Sheets(1).Range("A1").HorizontalAlignment = xlCenter            Set rng = .Sheets(1).Range("A2").Resize(UBound(arrTem, 2) + 1, UBound(arrTem, 1) + 1)        Else            Set rng = .Sheets(1).Range("A1").Resize(UBound(arrTem, 2) + 1, UBound(arrTem, 1) + 1)        End If        rng.NumberFormat = "@"        rng = Application.WorksheetFunction.Transpose(arrTem)        For i = 1 To rng.Columns.Count            For j = LBound(arrNumColFields) To UBound(arrNumColFields)                If rng.Cells(1, i).Value = arrNumColFields(j) Then                    Set col = rng.Columns(i)                    col.NumberFormatLocal = "_ * #,##0.00_ ;_ * -#,##0.00_ ;_ * ""-""??_ ;_ @_ "                    col.Value = col.Value                End If            Next            For j = LBound(arrDateColFields) To UBound(arrDateColFields)                If rng.Cells(1, i).Value = arrDateColFields(j) Then                    Set col = rng.Columns(i)                    col.NumberFormatLocal = "yyyy/m/d"                    col.Value = col.Value                End If            Next        Next        rng.Columns.AutoFit        .SaveAs fileName:=saveFolder & "\" & fileName        .Close    End WithEnd Sub

代码解析：

（1）根据是否插入标题，决定是从第一行还是第二行写入数据。

（2）设置rng大小。

（3）把整个rng的格式设置为文本。

（4）写入数据到rng。

（5）循环rng表头，循环数组arrNumColFields，把日期列设为日期格式，循环数组arrDateColFields，把数值列设为会计专用格式（保留2位小数，千位分隔），这里有句代码col.Value = col.Value，看似多此一举，但有它的作用，它通过回填自身来把日期变成真正的日期。

（6）设置rng自动列宽。

（7）保存、关闭文件。

关于批量设置单元格格式的问题，我们在前期分享文章【Excel VBA 按项目把总表拆分】中也有涉及，欢迎参阅。

在WPS中报错的问题

这个我就只能说抱歉了，我目前没有使用WPS，所以能否在WPS中正常运行，是没有经过测试的，理论上WPS应该能兼容OFFICE，大多应该能正常运行。

如果不能正常运行，我暂时没有好的解决办法。

关于WPS，我还是想啰嗦几句：

1、作为国产替代软件，它当然是头牌，好象也没有第二家。

2、我也用过WPS，它的功能已经是非常强大，几乎能完美兼容OFFICE，日常办公写个WORD文档，做个EXCEL表格，制作PPT完全没有问题。

3、但是（最怕这个但是）：