10、根据身份证号码自动提取性别和出生年月及求年龄的公式
这是根据身份证号码（15位和18位通用）自动提取性别和出生年月的自编公式，供需要的网友参考：
说明：公式中的B2或B4是身份证号
1、根据身份证号码求性别：
=IF(LEN(B2)=15,IF(MOD(value(RIGHT(B2,3)),2)=0,"女","男"),IF(LEN(B2)=18,IF(MOD(value(MID(B2,15,3)),2)=0,"女","男"),"身份证错"))
2、根据身份证号码求出生年月：
=IF(LEN(B4)=15,CONCATENATE("19",MID(B4,7,2),".",MID(B4,9,2)),IF(LEN(B4)=18,CONCATENATE(MID(B4,7,4),".",MID(B4,11,2)),"身份证错"))
3、根据身份证号码求年龄：
=IF(LEN(B4)=15,year(now())-1900-value(MID(B4,7,2)),if(LEN(B4)=18,year(now())-value(MID(B4,7,4)),"身份证错"))
11、结合各位大虾的代码,工作中写的工资表转工资条程序.
如题. 请各位指教, 如何进一步优化. 实际当中这样的功能已经不错了, 就懒得再改了, 哪位兄弟改进了欢迎贴上来共享.
' 工资总表转工资条程序
' 应用环境: Excel 2000 VBA
' 当前版本: 0.9c
'例:
'月份 工 號 項目 工 資 加 班 工 資 勤工 津 貼 應 得 工 資 應 扣 項 目 實 支 金 額 扣除 罰款 實 付 金 額 備註
' 姓名 底薪 津貼 工作 應得 應得 平時加班 假日加班 夜班 其他 稅款 箱.餐 插座 伙食 住宿 共扣
' 天數 工資 津貼 時間 金額 時間 金額 夜班 其他 牌 費 費 金額
'10月份 a-001 朱xx 16.00 26 416.00 107 285.33 0.00 32.00 108.00 20.00 861.33 20.00 15.00 35.00 826.33 826.33
'10月份 B-108 袁xx 16.00 25.5 408.00 150 400.00 0.00 32.00 840.00 40.00 15.00 55.00 785.00 785.00
Sub CreatePayRoll()
Dim TitleRow As Integer ' 工资表标题行数
Dim TitleCol As Integer ' 工资表标题栏数
Dim MyPageBreak As Integer ' 每页打印多少个工资条
CurVer = "0.9c" ' 当前版本号
TitleRow = 3
MyPageBreak = 7
response = MsgBox("本程序由 WongMokin 制作, 当前版本号 " & CurVer, vbOKOnly + vbInformation + vbDefaultButton0, "工资表转换成工资条", "", 0)
'先关闭屏幕刷新,免的闪
Application.ScreenUpdating = False
'实有工资条 = 取得当前区域的最后一行行号 - 标题行数
num = ActiveSheet.Range("A1").CurrentRegion.Rows.Count - TitleRow
num = InputBox("请在下面的输入框中键入要生成工资条的条数. " & Chr(13) & Chr(10) & Chr(13) & Chr(10) & _
"只能输入数值, 若输入其他内容将导致程序出错, 后果自负. " & Chr(13) & Chr(10) & Chr(13) & Chr(10) & _
"经检查共有工资记录: " & num & " 条", "要生成的工资条的条数", num)
If Int(num) < 1 Then
response = MsgBox("要生成的工资条数目太少,不需要执行此程序.", vbOKOnly + vbExclamation + vbDefaultButton0, "工资表转换成工资条 - 警告", "", 0)
Exit Sub
End If
'工资表的栏数，如 TitleCol = 10
TitleCol = 33
TitleCol = InputBox("请在下面的输入框中键入工资条表头的栏数. " & Chr(13) & Chr(10) & Chr(13) & Chr(10) & _
"只能输入数值, 若输入其他内容将导致程序出错, 后果自负. " & Chr(13) & Chr(10) & Chr(13) & Chr(10) & _
"默认值为: " & TitleCol, "工资条表头的栏数", TitleCol)
TitleCol = Int(Abs(Val(TitleCol))) '将输入的数值取正整数, 防止一般的输入性错误.
MyPageBreak = InputBox("每页打印多少条工资条?" & Chr(10) & Chr(13) & Chr(10) & Chr(13) & _
"预设每页打印 " & Int(MyPageBreak) & " 条" & Chr(10) & Chr(13), "工资表转成工资条", 7)
MyPageBreak = Int(Abs(Val(MyPageBreak)))
response = MsgBox("工资表转工资条的过程即将开始 " & Chr(13) & Chr(10) & Chr(13) & Chr(10) & _
"按 是(Yes) 后将开始进行转换, 未完成前您的电脑可能无法执行其他操作. " & Chr(13) & Chr(10) & _
"请先将您的Excel文档保存后再继续此操作. " & Chr(13) & Chr(10) & Chr(13) & Chr(10) & _
"工资条标题格式为 " & TitleRow & " 行 " & TitleCol & " 栏, 要转换的工资条数为: " & num & " 条" & _
"每页打印工资条数为: " & MyPageBreak & " 条", vbYesNo + vbExclamation + vbDefaultButton2, "工资表转工资条 - 执行前确认", "", 0)
If response = vbYes Then ' 用户按下 "是"
' 暂未使用
Else ' 用户按下 "否"
Exit Sub '退出此程序
End If
' 复制当前工作表并更改名字
ActiveSheet.Copy
ActiveSheet.Name = "工资条打印"
'总人数×5，如工资表中有100人则为100×5即num = 500
'即表头3行, 工资单一行, 空一行
num = Int(Abs(Val(num))) * (TitleRow + 2)
'判断有多少条记录
' x = ActiveSheet.Range("A1").CurrentRegion.Rows.Count
' or x = Range("a1").CurrentRegion.SpecialCells(xlCellTypeLastCell).Row
'开始插入标题
For y = 5 To (num - 1) Step 5
'将标题复制到记录上面
Rows("1:3").Select
Selection.Copy
Rows(y).Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
If y Mod MyPageBreak * (TitleRow + 2) = 0 Then
'插入分页符
Range("A" & y).PageBreak = xlPageBreakManual
End If
Next
Cells.Select
'选择整个表去掉表格线
Range("F1").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range(Cells(1, 1), Cells(4, TitleCol)).Select
Application.CutCopyMode = False
'定义表格边框线、内线样式
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
'返回或者设置边框的线型。可为下列 XlLineStyle 常量之一：
'xlContinuous、xlDash、xlDashDot、xlDashDotDot、xlDot、xlDouble、xlSlantDashDot 或 xlLineStyleNone。Variant 类型，可读写
.LineStyle = xlContinuous
'返回或者设置边框的粗细。可为下列 XlBorderWeight 常量：
'xlHairline、xlThin、xlMedium 或 xlThick。Long 类型，可读写
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlDash
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlDash
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Copy
num2 = 6
Do While num2 <= num
'循环复制表格线样式
Range(Cells(num2, 1), Cells(num2 + 3, TitleCol)).Select
'接上行删除上行尾的连字符，复制表格线样式
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
num2 = num2 + 5
Loop
Application.CutCopyMode = False '关掉剪切状态,也就是闪闪的虚框
Application.ScreenUpdating = True '恢复屏幕同步刷新
Application.DisplayAlerts = False '程序退出时不显示信息,比如剪贴板有资料时退出的提示.
response = MsgBox("转换完毕! 谢谢您的使用, 反馈及建议请及时联络我.", vbOKOnly + vbInformation + vbDefaultButton0, "工资表转换成工资条", "", 0)
End Sub
12、关于宏和程序
我现在已经用excel编了一个较完整的程序，并且能够给源程序加密码，实现"工程不可见"，但是我发现在vba编辑环境 里还能看到我的大部分宏，虽然说不能编辑，但能运行，请问如何隐藏起来
Q、不用模块函数,重写成类或放到workbook中,或在程序中直接将菜单宏隐藏。或：新建类，然后将模块中的程序拷贝到类，提示：找不到宏。
13、关于字符的比较！！！"3">"10"
一串数字，但是字符型的
"1","2",...."10","11",.....,"230","231"
我用>， < 号进行比较，发现"3"是>"10",“3”>"230"的，由于程序限制，不能把这些转化为数字型
那么如何做到"3"<"10","3"<"230",我想到用字符的长度进行较，如何实现
Q、程序中可以用以下代码实现：
columns("a:a").select
selection.sort key1:=range("a1"), order1:=xlascending, header:=xlguess, _
ordercustom:=1, matchcase:=false, orientation:=xltoptobottom, sortmethod _
:=xlpinyin, dataoption1:=xlsorttextasnumbers
注意其中的 dataoption1:=xlsorttextasnumbers
在工作表中手工操作时，选[i]数据[/i]菜单中的[i]排序[/i]，然后在弹出的对话框中按[i]选项[/i]，确认后会再弹出一个对话框，选第一项，确定就可以了
Q2、val("3")<val("10")
14、获得当前机器名和Excel用户名的代码
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, _
nSize As Long) As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
(ByVal lpBuffer As String, _
nSize As Long) As Long
Sub Get_Computer_Name()
'获得当前的机器名称
Dim Comp_Name_B As String * 255
Dim Comp_Name As String
GetComputerName Comp_Name_B, Len(Comp_Name_B)
Comp_Name = Left(Comp_Name_B, InStr(Comp_Name_B, Chr(0)))
MsgBox "您正在使用的这台机器名为：" & Comp_Name, vbOKOnly, "WINAK"
End Sub
Sub Get_User_Name()
Dim lpBuff As String * 25
Dim ret As Long, UserName As String
ret = GetUserName(lpBuff, 25)
UserName = Left(lpBuff, InStr(lpBuff, Chr(0)) - 1)
MsgBox "EXCEL用户名：" & UserName, vbOKOnly, "WINAK"
End Sub
A、 谢谢你，漂亮的大眼版主
不过Excel的用户名这样就可以取了：Application.UserName
Q、Application.User只是office中定义的用户名，可在工具－选项－用户名中更改；若要得到windows的登陆用户名，用Application.UserName就不行了。
Q2、做成自定义函数
Function User_Name()
User_Name = Application.UserName
End Function
14、以下公式希望能简化一些可以吗? =if(b1>0,vlookup(C1,C:D,2,)+vlookup(C1,E:F,2,0)+vlookup(C1,G:H,2,0)...................+vlookup(C1,BB:BC,2,0),"")其中Vlookup用的次要多达30次.请各位高手指教
Q、不用 vlookup 改用 sumif 即可解决。而且公式简洁多了，=SUMIF($A$4:$H$8,A11,$B$4:$B$8)
使用的函数是 SUMIF 不是 SUM。还能简化：=SUMIF($A$4:$G$8,A11,$B$4)
A、多谢你提供之公式 ,可以做到我须要的要求 ,真感激 .但有些问题是。A4:H8 是指所找寻的范围
A11 是指定的条件 ，但B4:B8 就不太明白 ,可否解释呢 ? 先谢
Q、SUMIF语法：SUMIF(range,criteria,sum_range)
内建说明 。sum_range 和范围是相对应的，当范围中的储存格符合搜寻筛选条件时，其对应的 sum_range 储存格会被加入总数 。所以$B$4:$B$10在此并不是加总的字段，而是相对应的 sum_range 储存格，也就是说找到符合A11数据时，将其右边一栏的储存格加总，如将$$4:$B$10改成$C$4:$C$10，就将其右边二栏的储存格加总 。公式简化后，sum_range 指向第一个储存格即可。
