批量转换18位身份证（已重新上传整套源文件）

耧斗菜 · 发表于 2016-6-22 10:56

本帖最后由耧斗菜于 2016-7-5 14:28 编辑

1、为何这段vba转身份证或退休年月后，都会自动锁定工作表？
2、是否能直接用于命令按钮中？
3、附件中有vba模块和excel文件
Option Explicit
Option Base 1
Private Sub FirstFormat() '初始化
If (MsgBox(Chr(13) & Chr(13) & "1、“初始化”将使《单位》、《人员》、《出表》工作表全部，" _
         & Chr(13) & Chr(13) & " 以及《说明》工作表的转换区域，全部清空！不可恢复！" _
         & Chr(13) & Chr(13) & "2、建议您在执行“初始化”之前，先做好数据备份。" _
         & Chr(13) & Chr(13) & "    是否继续？  确定将继续，取消将退出。", vbOKCancel + 48, "重要提示")) = 2 Then Exit Sub
Call OnOff(0, 0, 0, 0)

Call DeleteCB(0)
Call SheetLock(Sheets("单位"), 0)
Sheets("单位").Cells.Delete Shift:=xlUp '删除
Call SetDwDefault(0)
Call SheetLock(Sheets("单位"), 1)

Sheets("人员").Cells.Delete Shift:=xlUp '删除
Call AddRow1(0, 25)
Call SetRyDefault(0)

Call ClearSFZqy(0)
Call OnOff(1, 1, 1, 1)
Sheets("人员").Activate
Cells(1, 1).Activate
End Sub
Private Sub ClearSheetCB()
DeleteCB 1
End Sub
Private Sub DeleteCB(BoxShow As Integer)  '清空出表
If BoxShow = 1 Then
   If (MsgBox(Chr(13) & Chr(13) & "1、“清空出表”将使《出表》工作表数据全部清空！" _
            & Chr(13) & Chr(13) & "2、清空后，可使文件容量变小。若需要可继续生成。" _
            & Chr(13) & Chr(13) & "       是否继续？  确定将继续，取消将退出。", vbOKCancel + 48, "重要提示")) = 2 Then Exit Sub
End If
If BoxShow = 1 Then Call OnOff(0, 0, 0, 0)
If TestShtName(ThisWorkbook, "出表") Then ThisWorkbook.Sheets("出表").Delete
Sheets.Add after:=Worksheets("说明")
ActiveSheet.Name = "出表"
Call SheetLock(Sheets("出表"), True) '保护
If BoxShow = 1 Then Call OnOff(1, 1, 1, 1)
If BoxShow = 1 Then Cells(1, 1).Activate
End Sub
Private Sub ClearSFZqy1()
ClearSFZqy 1
End Sub
Private Sub ClearSFZqy(Show As Integer)  '清空转换区域
Call SheetLock(Sheets("说明"), 0)
Sheets("说明").Range("AG:AH").Clear 'Contents
Sheets("说明").Columns("AG:AH").ColumnWidth = 20 ' 宽
Call SheetLock(Sheets("说明"), 1)
Call CellFormat(3)
Sheets("说明").Activate
Cells(1, 33).Activate
End Sub
Private Sub SFZ1518() '身份证批量转换
Call ToChange(1)
End Sub
Private Sub TxnyChange() '退休年月批量转换
Call ToChange(2)
End Sub
Private Sub ToChange(x As Integer)  '批量转换身份证号码退休年月
Dim myBox1, myBox2, myBox3, Format1 As String
If x = 1 Then
   myBox1 = "身份证号码"
   myBox2 = "若输入15位，检测通过后转为18位；若输入18位，检测通过后返回原号码。"
   myBox3 = "省市、区县地址码不作检验。"
   Format1 = "@"
Else
   myBox1 = "退休年月"
   myBox2 = "待转换退休年月必须为6位或8位，格式必须如：“199807”、“20021231”。"
   myBox3 = "当长度=6，默认为1日。  当待转换退休年月有错，转换结果也有错。"
   Format1 = "yyyy-m-d"
End If
If (MsgBox(Chr(13) & Chr(13) & "1、请先在《说明》表的AG2～AG8001区域，输入需要转换的" & myBox1 & "。" _
         & Chr(13) & Chr(13) & "2、" & myBox2 _
         & Chr(13) & Chr(13) & " " & myBox3 _
         & Chr(13) & Chr(13) & "3、每次可批量转换1～8000个。" _
         & Chr(13) & Chr(13) & "4、转换结果，在其右侧单元格(AH列)，您可复制使用。" _
         & Chr(13) & Chr(13) & "       是否继续？  确定将继续，取消将退出。", vbOKCancel + 64, myBox1 & " …… 转换说明")) = 2 Then Exit Sub
Call OnOff(0, 0, 0, 0)
Dim i, j, ErrNum As Integer
ThisWorkbook.Sheets("说明").Activate
Call SheetLock(Sheets("说明"), 0)
Sheets("说明").Range("AH2:AH8001").ClearContents
Sheets("说明").Range("AH2:AH8001").NumberFormatLocal = Format1
j = 0
ErrNum = 0
For i = 2 To 8001
   If Len(Cells(i, 33)) > 0 Then
      If x = 1 Then
         Cells(i, 34) = SFZ(Cells(i, 33))
      Else
         Cells(i, 34) = DateToNum(Cells(i, 33))
      End If
      If Right(Cells(i, 34), 1) = "错" Then
         ErrNum = ErrNum + 1
      Else
         j = j + 1
      End If
   End If
Next i
Sheets("说明").Columns("AG:AH").ColumnWidth = 20 ' 宽
If j + ErrNum > 0 Then
   Sheets("说明").Cells(1, 33) = "待转换(" & myBox1 & ")"
   Sheets("说明").Cells(1, 34) = "已转换(" & myBox1 & ")"
End If
Call SheetLock(Sheets("说明"), 1)
Call OnOff(1, 1, 1, 1)
Cells(1, 34).Activate
MsgBox Chr(13) & Chr(13) & "1、共转换： " & j + ErrNum & " 个。其中：成功转换： " & j & " 个；存在错误： " & ErrNum & " 个。" _
      & Chr(13) & Chr(13) & "2、转换结果，在其右侧单元格(AH列)，您可复制使用。", vbOKOnly + 64, myBox1 & " …… 转换报告"
End Sub
Function DateToNum(myText As String) '退休年月转换
Dim i, l As Integer
Dim k As String
l = Len(myText)
If l <> 6 And l <> 8 Then
   DateToNum = "长度≠6或8错"
   Exit Function
End If
For i = 1 To l
      k = Mid(myText, i, 1)
      If Asc(k) < 48 Or Asc(k) > 57 Then
         DateToNum = "第" & i & "位非数字错"
         Exit Function
      End If
Next i
If Mid(myText, 1, 2) <> "19" And Mid(myText, 1, 2) <> "20" Then
   DateToNum = "非19或20年份错"
   Exit Function
End If
If l = 6 Then
   If Not IsDate(Mid(myText, 1, 4) & "-" & Trim(Str(Mid(myText, 5, 2))) & "-1") Then
      DateToNum = "年月日格式错"
      Exit Function
   End If
Else
   If Not IsDate(Mid(myText, 1, 4) & "-" & Trim(Str(Mid(myText, 5, 2))) & "-" & Trim(Str(Mid(myText, 7, 2)))) Then
      DateToNum = "年月日格式错"
      Exit Function
   End If
End If
If l = 6 Then DateToNum = Mid(myText, 1, 4) & "-" & Trim(Str(Mid(myText, 5, 2))) & "-1"
If l = 8 Then DateToNum = Mid(myText, 1, 4) & "-" & Trim(Str(Mid(myText, 5, 2))) & "-" & Trim(Str(Mid(myText, 7, 2)))
End Function

辅助.rar (1.92 KB, 下载次数: 4)

耧斗菜 · 发表于 2016-7-5 14:27

sfz.rar (143.99 KB, 下载次数: 1)

		自动登录	找回密码
密码			注册

批量转换18位身份证（已重新上传整套源文件）

相关帖子