1.excel制作文件目录:方法一
=INDEX(GET.WORKBOOK(1),ROW(目录!B4))&T(NOW())
=IFERROR(HYPERLINK(目录&"!A1",MID(目录,FIND("]",目录)+1,99)),"")
2.excel制作文件目录:方法二
=MID(GET.WORKBOOK(1),FIND("]",GET.WORKBOOK(1))+1,99)&T(NOW())
=IFERROR(HYPERLINK("#"&INDEX(Shname,ROW(A1))&"!a1",INDEX(Shname,ROW(A1))),"")
3.合并excel工作表:
=MID(GET.WORKBOOK(1),FIND("]",GET.WORKBOOK(1))+1,99)&T(NOW())
=INDEX(sh,INT((ROW(A1)-1)/6)+1)
=INDIRECT($A11&"!"&ADDRESS(COUNTIF($A$1:$A11,$A11)+1,COLUMN(A10)))
4.批量选择数据的明细:
=OFFSET('4449'!$B$3,0,0,MATCH((LOOKUP("座",'4449'!$C:$C)),'4449'!$C:$C,0)-2,2)
5.Indirect函数:=IFERROR(SUM(INDIRECT(A5&"!B:B")),"")
6.match函数:
7.Index函数:
8.vlookup函数:
9.hlookup函数
10.lookup函数:
11.round函数:
12.sumif函数:
13.sumifs函数:
14.SUMPRODUCT函数:
-------------------------------------------------------------------------------------------------------------------------------
1、制作excel文件目录：
步骤一:点击“公式”—定义名称“目录”—输入“=INDEX(GET.WORKBOOK(1),ROW(目录!B1))&T(NOW())”
步骤二：在目录工作表中输入“=IFERROR(HYPERLINK(目录&"!A1",MID(目录,FIND("]",目录)+1,99)),"")”，向下填充，有多少工作表填充多少行。
方法二：在工作表任意单元格中录入“=目录”，在相邻单元个录入“HYPERLINK("#"&A1&"!a1","点击跳转")”—向下填充
PS：返回目录：在出目录以为的工作表中的任意单元格输入“=HYPERLINK("#目录！a1","返回目录")”
2、取得硬盘指定目录下文件名
步骤一：新建一空白的Excel文件—“在A2单元格中设置数据验证”—“数据验证”— “序列”—“来源”处输入“*.*,*.xls,*.doc”
步骤二：定义名称"路径"—输入“=MID(CELL("filename"),1,FIND("[",CELL("filename"),1)-1)”
步骤三：定义名称“分类”—输入“=FILES(路径&目录!$A$2)&T(NOW())”
步骤四：在单元格B2中输入“=IF(ROW()-1>COUNTA(分类),"",HYPERLINK(路径&INDEX(分类,ROW(1:1)),INDEX(分类,ROW(1:1)))) "
注：工作表必须保存为启用宏的工作表。
3、制作动态下拉菜单
步骤：点击”公式”—“定义名称”—“输入$A$2:INDEX($A:$A,counta($A:$A))”
4、制作动态二级菜单
步骤一：定义名称：“区域”—输入“OFFSET($A$1,,,,COUNTA($1:$1))”
步骤二：定义名称：“姓名”—输入“OFFSET($A$2,,MATCH($B2,$1$1,)-1,COUNTA(OFFSET($A$2,,MATCH($B2,$1$1,)-1,100)))”
5、合并Excel工作表
步骤一：定义公式名称"SH"—输入"MID(GET.WORKBOOK(1),FIND"]",GET.WORKBOOK(1))+1,99)&T(NOW())"
步骤二：在A列输入"INDEX(SH,INT((ROW(A1)-1)/6)+1)"
步骤三：在B2中输入"INDIRECT($A2&"!"&ADDRESS(COUNTIF($A$1:$A2,$A2)+1,COLUMN(A1)))"
注：工作表必须保存为启用宏的工作表。
6、LOOK UP函数的经典用法
查找最后一条符合条件的记录：=LOOKUP(1,0/(条件区域=条件)，查询区域)
查找符合多个条件的记录：=LOOKUP(1,0/((条件区域1=条件1)* (条件区域2=条件2))，查询区域)
查找符合多个条件的记录:LOOKUP(1,0/((A12=$A$2:$A$9)*(B12=$C$2:$C$9)),$E$2:$E$9
逆向查找：LOOKUP(1,0/(B4:B11="A3",A4:A11)
逆向查找：LOOKUP(1,0/(E2=$B$2:$B$10,$A$2:$A$10)
LOOKUP(1,0/(条件区域<>""),查询区域)
查询A列的最后一个文本：=lookup("座",A:A)或者=lookup("々",A:A)
查询A列的最后一个数字：=lookup(9E307,A:A)
查询A列的最后一个单元格内容：=lookup(1,0/(A:A<>""),A:A)
查找最后一个非空值：LOOKUP(1,0/(B2:B13<>""),$A2:$A13)
单条件查找：LOOKUP(1,0/($B$2:$B$17=$H2),C$2:C$17)
双条件查找：LOOKUP(1，0/($A$2:$A$17=$M2)*($B$2:$17=$N2)),C$2:C$17)
区间查找：LOOKUP(F3，B$3:B$11，C$3:C$11)
一般查找：LOOKUP(1,0/(b2:b6=b9),e2:e6)
根据名称查找类别：LOOKUP(1,0/($B$2:$B$17=T2),$A$2:$A$17)
对合并类别单元格一一对应名称：LOOKUP(1,0/($A$23:A23<>""),$A$23:A23)
模糊查找：LOOKUP(9^9,FIND(A7,A$6:A10),B$3:B$6)
模糊查找：LOOKUP(9^9,find(A$3:A$6,A10),B$3:B$6)
关键字：LOOKUP(9^9,FIND(查找值,查找单元格),查找区域)
数字提取：
数字在开头:LOOKUP(9^9,LEFT(B1,ROW(1:9))*1)
数字在结尾:LOOKUP(9^9,RIGHT(B1,ROW(1:9))*1)
数字在任意位置:{=LOOKUP(9^9,MID(A1,MATCH(1,MID(A1,ROW(1:9),1)^0,0),ROW(1:9))*1)}
{=MATCH(,-FIND(ROW(A:A)%,A1))%}(方法二)
7、提取不重复的数据
=IFERROR(INDEX(A$2:A$13,MATCH(,COUNTIF(D$1:D1,A$2:A$13),)), "")
将满足条件的放同一个单元格：
=MID(SUBSTITUTE(PHONETIC(OFFSET(A$1,MATCH(D2,A$2:A$13,),,COUNTIF(A$2:A$13,D2),2)),D2, "、")2,99)
8、条件格式
突出显示重复值
=COUNTIF(A$2:A2,A2)>1
突出显示最小值
=B4=MIN($B4:$F4)
9、VLOOKUP函数
模糊查找：=VLOOKUP("*"&A10&"*",A2:B6,2,0)
多条件查找：=VLOOKUP(B9&C9,IF{1,0},B2:B6&A2:A6,E2:E6,2,0)按Ctrl+shift+enter
多表查找：=IFERROR(VLOOKUP(A2,服务!A:G,7,0),IFERROR(VLOOKUP(A2,人事!A:G,7,0), IFERROR(VLOOKUP(A2,综合!A:G,7,0),IFERROR(VLOOKUP(A2,财务!A:G,7,0), IFERROR(VLOOKUP(A2,销售!A:G,7,0), "无此人信息")))))
方法二：VLOOKUP(A2,INDIRECT(LOOKUP(1,0/COUNTIF(INDIRECT({"销售";"服务";"人事";"综合";"财务"}&"!A:A"),A2),{"销售";"服务";"人事";"综合";"财务"}&"!A:A")& "!A:G")7,0)
一对多查找：A2=B2&COUNTIF(B$1:B2,B2)
B11=IFERROR(VLOOKUP($A11&COLUMN(A1),$A:$C,3,0), "")
没有标题:=SUMPRODUCT((MOD(COLUMN(B3:G3),2)=0)*B3:G3)
=SUM(VLOOKUP(A3,A3:G3,ROW(1:3)*2,0))
多条件模糊求和：=SUMIFS(C2:C7,A2:A7,A11&"*",B2:B7,B11)
SUMPRODUCT(ISNUMBER(FIND(A11,A2:A7))*(B2:B7=B11)*C2:C7))
=SUMPRODUCT(SUBTOTAL(9,OFFSET(C2:J2,ROW(1:6),))*(B3:B8=B11))
=SUMPRODUCT(MMULT(C3:J8,ROW(1:8)^0)*(B3:B8=B11))
多表合并：INDIRECT(B$1&"!B"&ROW())
多表汇总：=SUMPRODUCT(SUMIF(INDIRECT(ROW($1:$5)& "!B:B"),A2,INDIRECT(ROW($1:$5) "!C:C")))
11、小写转换大写
1 =SUBSTITUTE(SUBSTITUTE(TEXT(TRUNC(FIXED(A2)),"[>0][dbnum2]G/通用格式元;[<0]负[dbnum2]G/通用格式元;;")&TEXT(RIGHT(FIXED(A2),2),"[dbnum2]0角0分;;"&IF(ABS(A2)>1%,"整",)),"零角",IF(ABS(A2)<1,,"零")),"零分","整")
2 =SUBSTITUTE(SUBSTITUTE(IF(A2>-0.5%,,"负")&TEXT(INT(FIXED(ABS(A2))),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(FIXED(A2),2),"[dbnum2]0角0分;;"&IF(ABS(A2)>1%,"整",)),"零角",IF(ABS(A2)<1,,"零")),"零分","整")
3 =SUBSTITUTE(SUBSTITUTE(IF(A2>-0.5%,,"负")&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(FIXED(A2),2),"[dbnum2]0角0分;;"&IF(ABS(A2)>1%,"整",)),"零角",IF(ABS(A2)<1,,"零")),"零分","整")
4 =SUBSTITUTE(SUBSTITUTE(IF(A2>-0.5%,,"负")&TEXT(INT(FIXED(ABS(A2))),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(FIXED(A2),2),"[dbnum2]0角0分;;"&IF(ABS(A2)>1%,"整",)),"零角",IF(ABS(A2)<1,,"零")),"零分","整")
5 =SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(IF(A2>-0.5%,,"负")&TEXT(INT(FIXED(ABS(A2))),"[dbnum2]")&TEXT(RIGHT(FIXED(A2),2),"[dbnum2]元0角0分;;元"&IF(ABS(A2)>1%,"整",)),"零角",IF(ABS(A2)<1,,"零")),"零元",),"零分","整")
6 =SUBSTITUTE(SUBSTITUTE(IF(A2>-0.5%,,"负")&IF(ABS(A2)+0.5%<1,,TEXT(INT(ABS(A2)+0.5%),"[dbnum2]")&"元")&TEXT(RIGHT(FIXED(A2),2),"[dbnum2]0角0分;;"&IF(ABS(A2)>1%,"整",)),"零角",IF(ABS(A2)<1,,"零")),"零分","整")
7 =IF(A2=0,"零",IF(A2>-0.5%,,"负")&TEXT(INT(ABS(A2)),"[dbnum2]G/通用格式元;;")&SUBSTITUTE(SUBSTITUTE(TEXT(RIGHT(FIXED(A2),2),"[dbnum2]0角0分;;"),"零角",IF(ABS(A2)<1,,"零")),"零分","整"))
8 =SUBSTITUTE(SUBSTITUTE(TEXT(TRUNC(FIXED(A2)),"[dbnum2]G/通用格式元;负[dbnum2]G/通用格式元;"&IF(A2>-0.5%,,"负"))&TEXT(RIGHT(FIXED(A2),2),"[dbnum2]0角0分;;"&IF(ABS(A2)>1%,"整",)),"零角",IF(ABS(A2)<1,,"零")),"零分","整")
9 =SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(IF(B8<0,"负",)&TEXT(INT(ABS(B8)),"[dbnum2];; ")&TEXT(MOD(ABS(B8)*100,100),"[>9][dbnum2]圆0角0分;[=0]圆整;[dbnum2]圆零0分"),"零分","整")," 圆零",)," 圆",)
10 =SUBSTITUTE(SUBSTITUTE(TEXT(INT(A1),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(A1/1%,2),"[dbnum2]0角0分;;"&IF(A1,"整",)),"零角","零"),"零分","整")
"大写（人民币）："&IF(A1-INT(A1)<0.005,TEXT(INT(A1),"[dbnum2]")&"元整",IF(A1*10-INT(A1*10)<0.05,TEXT(INT(A1),"[dbnum2]")&"元"&TEXT(INT(A1*10-INT(A1)*10),"[dbnum2]")&"角整",TEXT(INT(A1),"[dbnum2]")&"元"&TEXT(INT(A1*10-INT(A1)*10),"[dbnum2]")&"角"&TEXT((FIXED(A1*100,0)-INT(A1*10)*10),"[dbnum2]")&"分"))
11 =IF(ABS(A2)<0.5%,"",SUBSTITUTE(SUBSTITUTE(IF(A2<0,"负",)&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(FIXED(A2),2),"[dbnum2]0角0分;;整"),"零角",IF(ABS(A2)<1,,"零")),"零分","整"))
12 =SUBSTITUTE(SUBSTITUTE(IF(A1>-0.5%,,"负")&TEXT(INT(ABS(A1)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A1),2),"[dbnum2]0角0分;;"&IF(ABS(A1)>1%,"整",)),"零角",IF(ABS(A1)<1,,"零")),"零分","整")
13 =IF(ABS(A2)<0.5%,"",SUBSTITUTE(SUBSTITUTE(IF(A2<0,"负",)&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2),2),"[dbnum2]0角0分;;整"),"零角",IF(ABS(A2)<1,,"零")),"零分","整"))
14 =IF(-RMB(A2),SUBSTITUTE(SUBSTITUTE(IF(A2<0,"负",)&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2),2),"[dbnum2]0角0分;;整"),"零角",IF(ABS(A2)<1,,"零")),"零分","整"),"")
15 =SUBSTITUTE(IF(-RMB(A2),IF(A2<0,"负",)&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2),2),"[>9][dbnum2]0角0分;[>][dbnum2]0分;整"),""),"零分","整")
16 =SUBSTITUTE(IF(-RMB(A2),IF(A2<0,"负",)&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2),2),"[>9][dbnum2]0角0分;零[>][dbnum2]0分;整"),""),"零分","整")
17 =SUBSTITUTE(SUBSTITUTE(IF(-RMB(A1),IF(A1<0,"负",)&TEXT(INT(ABS(A1)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A1),2),"[dbnum2]0角0分;;整"),),"零角",IF(ABS(A1)<1,,"零")),"零分","整")
18 =TEXT(RMB(A1),"[=]g;"&TEXT(INT(ABS(A1)+0.5%),"[dbnum2]G/通用格式元;;")&SUBSTITUTE(SUBSTITUTE(TEXT(RIGHT(RMB(A1),2),"[dbnum2]0角0分;;整"),"零角",IF(ABS(A1)<1,,"零")),"零分","整"))
19 SUBSTITUTE(IF(-RMB(A2),IF(A2<0,"负",)&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2),2),"[>9][dbnum2]0角0分整;"&IF(ABS(A2)<1,,0)&"[>][dbnum2]0分;整"),),"零分",)
20 =SUBSTITUTE(IF(-RMB(A2),IF(A2>0,,"负")&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2),2),"[>9][dbnum2]0角0分;"&IF(A2^2<1,,0)&"[>][dbnum2]0分;整"),),"零分","整")
21 =SUBSTITUTE(SUBSTITUTE(IF(-RMB(A2),IF(A2>0,,"负")&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2),2),"[dbnum2]0角0分;;整"),),"零角",IF(A2^2<1,,"零")),"零分","整")
22 =SUBSTITUTE(IF(-RMB(A2),IF(A2<0,"负",)&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2),2),"[>9][dbnum2]0角0分整;"&IF(A2^2<1,,0)&"[>][dbnum2]0分;整"),),"零分",)
23 =TEXT(A2,";负")&SUBSTITUTE(TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&IF(-RMB(A2),TEXT(RIGHT(RMB(A2),2),"[>9][dbnum2]0角0分整;"&IF(A2^2<1,,0)&"[>][dbnum2]0分;整"),),"零分",)
24 =TEXT(RMB(A1),"[=]g;"&TEXT(INT(ABS(A1)+0.5%),"[dbnum2]G/通用格式元;;")&SUBSTITUTE(SUBSTITUTE(TEXT(RIGHT(RMB(A1),2),"[dbnum2]0角0分;;整"),"零角",IF(A1^2<1,,"零")),"零分","整"))
25 =SUBSTITUTE(IF(-RMB(A2),TEXT(A2,";负")&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2),2),"[>9][dbnum2]0角0分;"&IF(A2^2<1,,0)&"[>][dbnum2]0分;整"),),"零分","整")
26 =SUBSTITUTE(SUBSTITUTE(IF(-RMB(A2,2),TEXT(A2,";负")&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2,2),2),"[dbnum2]0角0分;;整"),),"零角",IF(A2^2<1,,"零")),"零分","整")
27 =TEXT(LEFT(RMB(A1),LEN(RMB(A1))-3),"[>0][dbnum2]G/通用格式元;[<0]负[dbnum2]G/通用格式元;;") & TEXT(RIGHT(RMB(A1),2),"[dbnum2]0角0分;;整")
28 TEXT(INT(A3),"[dbnum2]")&"元"&IF(INT(A3*10)-INT(A3)*10=0,"",TEXT(INT(A3*10)-INT(A3)*10,"[dbnum2]")&"角")&IF(INT(A3*100)-INT(A3*10)*10=0,"整",TEXT(INT(A3*100)-INT(A3*10)*10,"[dbnum2]")&"分")
29 =IF(OR(B1="",B1=0),"",TEXT(INT(B1,"[dbnum2]G/通用格式元;[dbnum2]G/通用格式元;;")&TEXT(--RIGHT(INT(B1*10)),"[dbnum2]#角;;;")&TEXT(--RIGHT(INT(B1*100)),"[dbnum2]#分;;整;"))
--------------------------------------------------------------------------------------------
12、SUBSTITUTE常用方法
例1：=SUBSTITUTE(B2, "A", "B")
例2：=SUBSTITUTE(B2，MID(B2,4,5), "*****")
例3：数据分列：=TRIM(MID(SUBSTITUTE($B2, "、",REPT("",100)),COLUMN(A1)*100-99,100))
例4：=SUMPRODUCT(--SUBSTITUTE(B2:B6,"人",))
13、阶梯电价的计算方式
=SUM(TEXT(A2-{0,260,600}, "0;!0")*{0.68,0.05,0.25})
14、按指定次数重复数据：
=IFERROR(VLOOKUP(ROW(A1),A:B,2，0),E3)&""
15、offset的用法：
下拉菜单：=OFFSET($C$1，MATCH(A2&"*",C:C,0)-1,,COUNTAIF(C:C,A2&"*"),1)
动态图表的制作：
定义名称：日期=OFFSET($A$1,COUNT($A:$A),0,-7)
定义名称：销售额=OFFSET($B$1,COUNT($A:$A),0,-7)
分组求和：=SUM(OFFSET($A2,,(COLUMN()-COLUMN($M$1))*3,,3))
间隔取值：OFFSET($A2,,(COLUMN()-COLUMN($M$1))*3,,1)
动态确定求和的数据区域：=SUMIF($A:$A,$O2,OFFSET($A:$A,,MATCH(P$1,$B$1:$M$1,0)))
动态显示最近几天的总数量：
=SUM(OFFSET(B1，COUNT(B:B)-D2+1,,D2))
=SUM(OFFSET(B1,COUNTA(B:B),,-D2))
创建二级下拉菜单：
一级菜单=OFFSET(二级下拉菜单$A$1,1,,COUNTA(二级下拉菜单$A:$A)-1)
二级菜单=OFFSET(二级下拉菜单$B$1,MATCH(二级下拉菜单G2,一级菜单,0),,,COUNTA(OFFSET(二级下拉菜单$B$1:$E$1,MATCH(二级下拉菜单G2,一级菜单，0),)))
创建动态数据透视表：
=OFFSET(动态的数据透视表$A:$1,,,COUNTA(动态的数据透视表$A:$A),COUNTA(动态的数据透视表$1:$1))
Excel多表相同项求和
1、 定义名称：SH=MID(GET.WORKBOOK(1),FIND("]",GET.WORKBOOK(1)+1,99)&T(NOW())
2、 求和：=SUMPRODUCT((SUMIF(INDIRECT(SH&”!b:b”),D2,INDIRECT(SH&"!C:C"))))
Excel双向查找：
1、 =OFFSET($B$2,MATCH(B10,B3:B7,0),MATCH(C10,C2:H2,0))
2、 =INDEX(C3:H7,MATCH(B10,B3:B7,0),MATCH(C10,C2:H2,0))
3、 =VLOOKUP(B10,$B$3:$H$7,MATCH(C10,$C$2:$H$2,0)+1,0)
4、 =INDIRECT(ADDRESS(MATCH(B10,B1:B7,0),MATCH(C10,A2:H2,0),,,"sheet1"))
5、 =HLOOKUP(C10,C2:H7,MATCH(B10,B2:B7,0),0)
6、 =LOOKUP(1,0/(B10=B2:B7),OFFSET(B2:B7,,MATCH(C10,B2:H2,0)-1,))
7、 =SUMPRODUCT(($B$3:$B$7=B10)*($C$2:$H$2=C10)*$C$3:$H$7)
8、 =SUM((B3:B7=B10)*(C2:H2=C10)*(C3:H7)) 数组公式
9、 =MAX((B3:B7=B10)*(C2:H2=C10)*(C3:H7))
Look up高级用法
--------------------------------------------------------------------------------------------
数字在开头
A1的值为 123.45ABC
公式：
=LOOKUP(9^9,LEFT(B1,ROW(1:9))*1)
截取结果：123.45
数字在结尾
A1的值为 ABC123.45
公式： =LOOKUP(9^9,RIGHT(B1,ROW(1:9))*1)
截取结果：123.45
----------------------------------------------------------------------------------------------
数字在任意位置。
A1的值为 ABC123.45FE
数组公式：{=LOOKUP(9^9,MID(A1,MATCH(1,MID(A1,ROW(1:9),1)^0,0),ROW(1:9))*1)}
截取结果：123.45
其他公式1： =LOOKUP(9E+307,--MID(F72,MIN(FIND({0;1;2;3;4;5;6;7;8;9},A1&1234567890)),ROW(INDIRECT("1:"&LEN(F72)))))
其他公式2：=SUM(MID(0&F72,1+LARGE(ISNUMBER(-MID(F72,ROW($1:$32),1))*ROW($1:$32),ROW($1:$15)),1)*10^ROW($2:$16))%（混合字符）——备注：颜色标记部分，可根据提取单元格字符长短修改
其他公式3=IF(LEN(MID(SUM(MID("01"&F72,1+LARGE(ISNUMBER(-MID(1&F72,ROW($1:$50),1))*ROW($1:$50),ROW($1:$15)),1)*10^ROW($2:$16))%,2,99))>=8,RIGHT(LEFT(MID(SUM(MID("01"&F72,1+LARGE(ISNUMBER(-MID(1&F72,ROW($1:$50),1))*ROW($1:$50),ROW($1:$15)),1)*10^ROW($2:$16))%,2,99),8),4),0)
--------------------------------------------------------------------------------------------
表格核对
1、开始—条件格式—使用公式确定——（引用单元格=cell（"contents"））—突出显示差异单元格
2、同行数据对比：选中两列——按CTLR+\
3、相同数值不同行（单列无重复值）：条件格式—突出显示单元格规则—重复值
4、相同数值不同行（单列有重复值）：数据—高级筛选—列表区域（一列）——条件区域（另一列）——确定
5、不同工作表核对：=countif（工作表1A:A,A2）—通过数据筛选——筛选大于0的
6、多表核对：使用多条件就和做差法
7、两个表格数值类型对比：使用选择性粘贴—减的方法核对
8、不限数值类型对比：开始—条件格式—使用公式确定—输入“A2<>C2”—用颜色标记出
9、位置不同的两表核对：开始—条件格式—使用公式确定—输入“Vlookup($H11,$H$2:$N$8,COLUMN()-7,0)”—用颜色标记出
=LOOKUP(9E+307,--MID(H2,MIN(FIND({0;1;2;3;4;5;6;7;8;9},H2&1234567890)),ROW(INDIRECT("1:"&LEN(H2)))))
=========================================================================
VBA:
1. Sub BalanceCalculate()
Dim ws As Worksheet, n
For Each ws In Worksheets
For n = 5 To [A1048576].End(xlUp).Row
If ws.Name = Cells(n, 1) Then
a = ws.[f1048576].End(xlUp)
Sheet2.Cells(n, 9) = a
End If
Next
Next
End Sub
--------------------------------------------------------------------------------------------
2. Sub Dataclassification()
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name = Sheets("数据汇总").Range("h2") Then
'Rs = ws.UsedRange.Rows.Count + 1
Sheets("数据汇总").Select
ends = ws.[a:a].Find("*", searchdirection:=xlPrevious).Row + 1
Range("i4", [M1048576].End(xlUp)).Copy ws.Cells(ends, 1)
End If
Next
End Sub
--------------------------------------------------------------------------------------------
3.Sub DataImport()
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Users\Administrator\Desktop\2015.txt", Destination:=Range("$A$1"))
' .CommandType = 0
.Name = "2015_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 936
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "^"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
--------------------------------------------------------------------------------------------
4. Sub Datasearch()
Dim rng As Range, i
i = 3
j = 2
ends = Sheets("数据汇总").[a:a].Find("*", searchdirection:=xlPrevious).Row
For Each rng In Range("a5:a" & ends)
i = i + 1
If rng Like Range("H2") Then
j = j + 1
Range("a" & i + 1 & ":e" & i + 1).Copy Range("h" & j + 1)
End If
Next
End Sub
--------------------------------------------------------------------------------------------
5.制作目录
Sub Index()
Dim ws As Worksheet, i
i = 3
Sheets("目录").Cells(3, 3) = "目录"
For Each ws In Worksheets
If ws.Name <> "目录" Then
Sheets("目录").Cells(i, 3) = ws.Name
End If
i = i + 1
Next
End Sub
--------------------------------------------------------------------------------------------
6.查询
Sub IndexExchangeDetail()
Dim ws As Worksheet
If Cells(4, 7) = "" Then
MsgBox "请输入需要查询的账户"
End If
For Each ws In Worksheets
If Cells(4, 7) = ws.Name Then
ws.Select
ws.Range([d3], [e1048576].End(xlUp)).Select
End If
Next
End Sub
--------------------------------------------------------------------------------------------
7.查询
Sub IndexRevenueDetail()
Dim ws As Worksheet
If Cells(4, 4) = "" Then
MsgBox "请输入需要查询的账户"
End If
For Each ws In Worksheets
If Cells(4, 4) = ws.Name Then
ws.Select
ws.Range([b3], [C1048576].End(xlUp)).Select
End If
Next
End Sub
--------------------------------------------------------------------------------------------8.合并工作表
Sub Marge()
Dim i%, rs%, rss%, st As Worksheet, zst As Worksheet
Set zst = Sheets("汇总表")
For i = 3 To 5
Set st = Sheets(i)
rs = st.UsedRange.Rows.Count
rss = zst.UsedRange.Rows.Count + 1
st.Range("a2:g" & rs).Copy zst.Cells(rss, 1)
zst.Cells(rss, 7).Resize(rs - 1) = i
Next
End Sub
-------------------------------------------------------------------------------------------
9.PaidoutCalculate
Sub PaidoutCalculate()
Dim ws As Worksheet, n
Sum = 0
For Each ws In Worksheets
For n = 5 To [A1048576].End(xlUp).Row
If ws.Name = Cells(n, 1) Then
For i = 3 To ws.[d1048576].End(xlUp).Row
Sum = Sum + ws.Cells(i, 4)
Next
Sheet2.Cells(n, 6) = Sum
Sum = 0
End If
Next
Next
End Sub
--------------------------------------------------------------------------------------------
10.RevenueCalculate
Sub RevenueCalculate()
Dim ws As Worksheet, n
Sum = 0
For Each ws In Worksheets
For n = 5 To [A1048576].End(xlUp).Row
If ws.Name = Cells(n, 1) Then
For i = 3 To ws.[b1048576].End(xlUp).Row
Sum = Sum + ws.Cells(i, 2)
Next
Sheet2.Cells(n, 3) = Sum
Sum = 0
End If
Next
Next
End Sub
--------------------------------------------------------------------------------------------
11.窗体显示
Sub ShowRevenueData()
PaidoutData.Show
End Sub
----------------------
Sub ShowRevenueData()
RevenueData.Show
End Sub
--------------------------------------------------------------------------------------------
12.拆分工作表
Sub Split()
For i = 3 To 5
Worksheets.Add.Name = i
For Each rng In Sheets("汇总表").Range("g2:g540")
If rng.Value = i Then
n = "g" & rng.Row & ":a" & rng.Row
y = y + 1
If y = 3 Then
Sheets("汇总表").Range("a1:d1").Copy Sheets(i).Cells(y, 1)
End If
Sheets("汇总表").Range(n).Copy Sheets(i).Cells(y + 1, 1)
End If
Next
y = 0
Next
End Sub
--------------------------------------------------------------------------------------------
13.工作表密码破解
Sub unprotect() '破解excel密码
Dim ws As Worksheet
For Each ws In Worksheets
ws.Protect AllowFiltering:=True
ws.unprotect
End Sub
--------------------------------------------------------------------------------------------
14.RevenueData
Private Sub Cancel_Click()
Unload RevenueData
End Sub
---------------------------
Private Sub OK_Click()
Dim ws As Worksheet, n
If TextBox1 = "" And TextBox2 = "" And TextBox3 = "" And TextBox4 = "" Then
MsgBox "请输入数据,然后再点击增加"
End If
For Each ws In Worksheets
If TextBox1.Value = ws.Name Then
ws.Activate
ends = Columns(1).Find("*", , , , , searchdirection:=xlPrevious).Row
Cells(ends + 1, 1) = TextBox2.Value
Cells(ends + 1, 2) = TextBox3.Value
Cells(ends + 1, 3) = TextBox4.Value
' ws.[A1048576].End(xlUp)(1, 0) = TextBox2.Value
' ws.[A1048576].End(xlUp)(1, 1) = TextBox3.Value
' ws.[A1048576].End(xlUp)(1, 2) = TextBox4.Value
MsgBox "数据添加完成!"
End If
Next
Unload RevenueData
MsgBox "您已退出系统,欢迎再次使用"
End Sub
--------------------------------------------------------------------------------------------
15.用户登录界面
Private Sub Cancel_Click()
Unload Login
End Sub
=============================
Private Sub OK_Click()
If TextBox1 = "admin" And TextBox2 = "123456" Then
MsgBox "登录成功,欢迎使用本系统"
Unload Login
Application.Visible = True
Else
MsgBox "用户或密码不正确,请您核实之后重新输入"
ThisWorkbook.Application.Quit
End If
End Sub
--------------------------------------------------------------------------------------------
一键生成带目录的超链接：
Sub ml()
Dim sht As Worksheet, i&, shtname$
Columns(1).ClearContents '清空A列数据
Cells(1, 1) = "目录"
'第一个单元格写入字符串"目录"
i = 1
'将i的初值设置为1.
For Each sht In Worksheets
'循环当前工作簿的每个工作表
shtname = sht.Name
If shtname <> ActiveSheet.Name Then
'如果sht的名称不是当前工作表的名称则开始在当前工作表建立超链接
i = i + 1
'累加i
ActiveSheet.Hyperlinks.Add anchor:=Cells(i, 1), Address:="",SubAddress:="'" & shtname & "'!a1",TextToDisplay:=shtname
'建超链接
End If
Next
End Sub
--------------------------------------------------------------------------------------------
一键批量取消隐藏工作表：
Sub qxyc()
Dim sht As Worksheet
'定义变量
For Each sht In Worksheets
'循环工作簿里的每一个工作表
sht.Visible = xlSheetVisible
'将工作表的状态设置为非隐藏
Next
End Sub
--------------------------------------------------------------------------------------------
批量该工作表名称：
Sub rename()
Dim shtname$, sht As Worksheet, i&
On Error Resume Next
'当程序运行中出现错误时，继续运行
For i = 1 To Cells(Rows.Count, 1).End(3).Row
'遍历当前表格A列的数据
shtname = Cells(i, 1)
'将表格A列的值，赋予变量shtname
'之所以将shtname的变量类型定义为文本，是防止A列数据为数值时和sheet序列引用产生冲突。
Set sht = Sheets(shtname)
If Err = 0 Then
'如果工作簿存在sht表，则更名
Sheets(shtname).Name = Cells(i, 2)
Else
'如果工作薄不存在sht表，则清除错误，对下一个值判断处理
Err.Clear
End If
Next
End Sub
--------------------------------------------------------------------------------------------
提取工作表名称：
Sub ml()
Dim sht As Worksheet, k&
[a:a] = ""
'清空A列数据
[a1] = "目录"
k = 1
For Each sht In Worksheets
'遍历工作簿中每个工作表
k = k + 1
'累加K值
Cells(k, 1) = sht.Name
'将工作表名称依次放入表格A列
Next
End Sub
--------------------------------------------------------------------------------------------
重新排序工作表
Sub sortsheet()
Dim sht As Worksheet, shtname$, i&
Set sht = ActiveSheet
'设置变量sht为当前激活的工作表，即目录表。
For i = 2 To sht.Cells(Rows.Count, 1).End(3).Row
'遍历工作表A列的数据，A1以外。
shtname = sht.Cells(i, 1)
'将A列值赋值为字符串变量shtname
Sheets(shtname).Move after:=Sheets(i- 1)
'将工作表依次移动
Next
sht.Activate
'重新激活目录表
End Sub
--------------------------------------------------------------------------------------------
一键汇总个分表数据到总表
Sub collect()
'VBA编程学习与实践，一键多表数据汇总
Dim sht As Worksheet, rng As Range, k&, trow&
Application.ScreenUpdating = False
'取消屏幕更新，加快代码运行速度
trow = Val(InputBox("请输入标题的行数", "提醒"))
If trow < 0 Then MsgBox "标题行数不能为负数。", 64, "警告": Exit Sub
'取得用户输入的标题行数，如果为负数，退出程序
Cells.ClearContents
'清空当前表数据
For Each sht In Worksheets
'循环读取表格
If sht.Name <> ActiveSheet.Name Then
'如果表格名称不等于当前表名则进行汇总动作……
Set rng = sht.UsedRange
'定义rng为表格已用区域
k = k + 1
'累计K值
If k = 1 Then
'如果是首个表格，则K为1，则把标题行一起复制到汇总表
rng.Copy
[a1].PasteSpecial Paste:=xlPasteValues
Else
'否则，扣除标题行后再复制黏贴到总表，只黏贴数值
rng.Offset(trow).Copy
Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1).PasteSpecial Paste:=xlPasteValues
End If
End If
Next
[a1].Activate
'激活A1单元格
Application.ScreenUpdating = True
'恢复屏幕刷新
End Sub
--------------------------------------------------------------------------------------------
指定名称批量建立工作表
Sub NewSht()
'ExcelHome VBA编程实践与学习
Dim Sht As Worksheet, Rng As Range
Dim Sn, t$
Set Rng = Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
'将工作表名称所在的单元格区域赋值给变量Rng，单元格A1是标题，不读入
On Error Resume Next
'当代码出错时继续运行
For Each Sn In Rng
'遍历Rng(工作表名称集合）
t = Sn
'还记得这里我们为什么用这句代码吗？
Set Sht = Sheets(t)
'当工作簿不存在工作表Sheets(t)时，这句代码会出错，然后……
If Err Then
'如果代码出错，说明不存在工作表Sheets(t)，则新建工作表
Worksheets.Add , Sheets(Sheets.Count)
'新建一个工作表，位置放在所有已存在工作表的后面
ActiveSheet.Name = t
'新建的工作表必然是活动工作表，为之命名
Err.Clear
'清除错误状态
End If
Next
Rng.Parent.Activate
'重新激活名称数据所在的工作表
End Sub
---------------------------------------------------------------------------------------------
一键拆分总表到个分表
Sub NewShts()
Dim d As Object, sht As Worksheet, arr, brr, r, kr, i&, j&, k&, x&
Dim Rng As Range, Rg As Range, tRow&, tCol&, aCol&, pd&
Application.ScreenUpdating = False '关闭屏幕更新
Application.DisplayAlerts = False '关闭警告信息提示
Set d = CreateObject("scripting.dictionary") 'set字典
Set Rg = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)
'用户选择的拆分依据列
tCol = Rg.Column '取拆分依据列列标
tRow = Val(Application.InputBox("请输入总表标题行的行数？"))
'用户设置总表的标题行数
If tRow = 0 Then MsgBox "你未输入标题行行数，程序退出。": Exit Sub
Set Rng = ActiveSheet.UsedRange '总表的数据区域
arr = Rng '数据范围装入数组arr
tCol = tCol - Rng.Column + 1 '计算依据列在数组中的位置
aCol = UBound(arr, 2) '数据源的列数
For i = tRow + 1 To UBound(arr) '遍历数组arr
If Not d.exists(arr(i, tCol)) Then
d(arr(i, tCol)) = i '字典中不存在关键词则将行号装入字典
Else
d(arr(i, tCol)) = d(arr(i, tCol)) & "," & i '如果存在则合并行号，以逗号间隔
End If
Next
For Each sht In Worksheets '遍历一遍工作表，如果字典中存在则删除
If d.exists(sht.Name) Then sht.Delete
Next
kr = d.keys '字典的key集
For i = 0 To UBound(kr) '遍历字典key值
If kr(i) <> "" Then '如果key不为空
r = Split(d(kr(i)), ",") '取出item里储存的行号
ReDim brr(1 To UBound(r) + 1, 1 To aCol)'声明放置结果的数组brr
k = 0
For x = 0 To UBound(r)
k = k + 1 '累加记录行数
For j = 1 To aCol '循环读取列
brr(k, j) = arr(r(x), j)
Next
Next
With Worksheets.Add(, Sheets(Sheets.Count))
'新建一个工作表，位置在所有已存在sheet的后面
.Name = kr(i) '表格命名
.[a1].Resize(tRow, aCol) = arr '放标题行
.[a1].Offset(tRow, 0).Resize(k, aCol) = brr'放置数据区域
Rng.Copy '复制粘贴总表的格式
.[a1].PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.[a1].Select
End With
End If
Next
Sheets(1).Activate '激活第一个表格
Set d = Nothing '释放字典
Erase arr: Erase brr '释放数组
MsgBox "数据拆分完成！"
Application.ScreenUpdating = True '恢复屏幕更新
Application.DisplayAlerts = True '恢复警示
End Sub
--------------------------------------------------------------------------------------------
批量将工作表转换为工作簿
Sub newbooks()
Dim sht As Worksheet, mypath$
Application.DisplayAlerts = False
'取消显示系统警告和消息
Application.ScreenUpdating = False
'取消屏幕刷新
With Application.FileDialog(msoFileDialogFolderPicker)
'选择保存工作薄的文件路径
.AllowMultiSelect = False
'不允许多选
If .Show Then
mypath = .SelectedItems(1)
'读取选择的文件路径
Else
Exit Sub
'如果没有选择保存路径，则退出程序
End If
End With
If Right(mypath, 1) <> "\" Then mypath = mypath & "\"
For Each sht In Worksheets
'遍历工作表
sht.Copy
'复制工作表，工作表单纯复制后，成为活动工作薄
With ActiveWorkbook
.SaveAs mypath & sht.Name, xlWorkbookDefault
'保存活动工作薄到指定路径下
.Close True '关闭工作薄
End With
Next
MsgBox "处理完成。", , "提醒"
Application.ScreenUpdating = True '恢复屏幕刷新
Application.DisplayAlerts = True '恢复显示系统警告和消息
End Sub
---------------------------------------------------------------------------------------------
将总表分拆各个工作簿：
Sub Newbooks()
Dim d As Object, arr, brr, r, kr, i&, j&, k&, x&
Dim Rng As Range, Rg As Range, tRow&, tCol&, aCol&, pd&, mypath$
Dim Cll As Range, sht As Worksheet
Application.ScreenUpdating = False '取消屏幕刷新
Application.DisplayAlerts = False '取消警告信息提醒，当有重名工作簿时直接覆盖保存。
'
'
'第一部分，用户选择保存分表工作簿的路径。
With Application.FileDialog(msoFileDialogFolderPicker)
'选择保存工作薄的文件路径
.AllowMultiSelect = False
'不允许多选
If .Show Then
mypath = .SelectedItems(1)
'读取选择的文件路径
Else
Exit Sub
'如果没有选择保存路径，则退出程序
End If
End With
If Right(mypath, 1) <> "\" Then mypath = mypath & "\"
'第二部分遍历总表数据，通过字典将指定字段的不同明细行过滤保存
Set d = CreateObject("scripting.dictionary") 'set字典
Set Rg = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)
'用户选择的拆分依据列
tCol = Rg.Column '取拆分依据列列标
tRow = Val(Application.InputBox("请输入总表标题行的行数？"))
'用户设置总表的标题行数
If tRow = 0 Then MsgBox "你未输入标题行行数，程序退出。": Exit Sub
Set Rng = ActiveSheet.UsedRange '总表的数据区域
Set Cll = ActiveSheet.Cells '用于在分表粘贴和总表同样行高列宽的数据格式
arr = Rng '数据范围装入数组arr
tCol = tCol - Rng.Column + 1 '计算依据列在数组中的位置
aCol = UBound(arr, 2) '数据源的列数
For i = tRow + 1 To UBound(arr) '遍历数组arr
If Not d.exists(arr(i, tCol)) Then
d(arr(i, tCol)) = i '字典中不存在关键词则将行号装入字典
Else
d(arr(i, tCol)) = d(arr(i, tCol)) & "," & i '如果存在则合并行号，以逗号间隔
End If
Next
'
'
'第三部分遍历字典取出分表数据明细，建立不同工作簿保存数据。
kr = d.keys '字典的key集
For i = 0 To UBound(kr) '遍历字典key值
If kr(i) <> "" Then '如果key不为空
r = Split(d(kr(i)), ",") '取出item里储存的行号
ReDim brr(1 To UBound(r) + 1, 1 To aCol) '声明放置结果的数组brr
k = 0
For x = 0 To UBound(r)
k = k + 1 '累加记录行数
For j = 1 To aCol '循环读取列
brr(k, j) = arr(r(x), j)
Next
Next
With Workbooks.Add
'新建一个工作簿
With .Sheets(1).[a1]
Cll.Copy '复制粘贴总表的单元格格式
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Resize(tRow, aCol) = arr '放标题行
.Offset(tRow, 0).Resize(k, aCol) = brr '放置数据区域
.Select
End With
.SaveAs mypath & kr(i), xlWorkbookDefault '保存工作簿
.Close True '关闭工作簿
End With
End If
Next
'
'
'收尾巴。
Set d = Nothing '释放字典
Erase arr: Erase brr '释放数组
MsgBox "处理完成。", , "提醒"
Application.ScreenUpdating = True '恢复屏幕刷新
Application.DisplayAlerts = True '恢复显示系统警告和消息
End Sub
--------------------------------------------------------------------------------------------
获取制定文件夹下文件：
Sub FileDir()
Dim p$, f$, k&
'获取用户选择文件夹的路径
With Application.FileDialog(msoFileDialogFolderPicker)
'选择文件夹
.AllowMultiSelect = False
'不允许多选
If .Show Then
p = .SelectedItems(1)
'选择的文件路径赋值变量P
Else
Exit Sub
'如果没有选择保存路径，则退出程序
End If
End With
If Right(p, 1) <> "\" Then p = p & "\"
f = Dir(p & "*.*")
'返回变量P路径下带任意扩展名的文件名。如果超过一个文件存在，函数将返回按条件第一个找到的文件名。
'如果一个文件都没有，则f返回""
[a:a].ClearContents '清空A列数据
[a1] = "目录"
k = 1 'K
Do While f <> "" '如果f不等于""，则……
k = k + 1 '累加K
Cells(k, 1) = f
f = Dir
' 若第二次调用 Dir 函数，但不带任何参数，则将返回同一目录下的下一个文件。
Loop
MsgBox "OK"
End Sub
---------------------------------------------------------------------------------------------
汇总多个工作簿每一个工作表名称包含关键字的数据到总表：
Sub Collectwks()
'ExcelHome VBA编程学习与实践
Dim Sht As Worksheet, Rng As Range, Sh As Worksheet
Dim Trow&, k&, arr, brr, i&, j&, book&, a&
Dim p$, f$, Headr, Keystr
Application.ScreenUpdating = False '关闭屏幕更新
On Error Resume Next '忽略代码运行中可能出现的错误继续运行
'
With Application.FileDialog(msoFileDialogFolderPicker)
'取得用户选择的文件夹路径
.AllowMultiSelect = False
If .Show Then
p = .SelectedItems(1)
Else
Exit Sub
End If
End With
If Right(p, 1) <> "\" Then p = p & "\"
'
Keystr = InputBox("请输入需要合并的工作表所包含的关键词：", "提醒")
If StrPtr(Keystr) = 0 Then Exit Sub
'如果点击了inputbox的取消或者关闭按钮，则退出程序
Trow = Val(InputBox("请输入标题的行数", "提醒"))
If Trow < 0 Then MsgBox "标题行数不能为负数。", 64, "警告": Exit Sub
Set Sht = ActiveSheet
Cells.ClearContents
Cells.NumberFormat = "@"
'清空当前表数据并设置为文本格式
'
f = Dir(p & "*.xls") '开始遍历工作簿
Do While f <> ""
If f <> ThisWorkbook.Name Then '避免同名文件重复打开出错
With GetObject(p & f)
'以'只读'形式读取文件时，使用getobject方法会比workbooks.open稍快
For Each Sh In .Worksheets '遍历表
If InStr(1, Sh.Name, Keystr, vbTextCompare) Then
'如果表中包含关键词则进行汇总(不区分关键词字母大小写）
arr = .Sheets(1).UsedRange '数据区域读入数组arr
book = book + 1 '标记一下是否首个Sheet
If book = 1 Then
ReDim brr(1 To 200000, 1 To UBound(arr, 2) + 1)
'如果是首个表格，则声明一个结果数组,20万行
Headr = Sh.[a1].Resize(Trow, UBound(arr, 2))
'将标题装入数组
a = Trow + 1 '扣掉标题行后的数据区域的开始行
End If
For i = a To UBound(arr) '遍历行
k = k + 1 '累加记录条数
brr(k, UBound(brr, 2)) = Sh.Name '结果数组brr的最后一列装入表名
For j = 1 To UBound(arr, 2) '遍历列
brr(k, j) = arr(i, j)
Next
Next
End If
Next
.Close False '关闭工作簿
End With
End If
f = Dir '下一个表格
Loop
If k > 0 Then
With Sht.[a1]
.Resize(Trow, UBound(Headr, 2)) = Headr '放标题
.Offset(Trow - 1, UBound(Headr, 2)) = "来源表名"
.Offset(Trow).Resize(k, UBound(brr, 2)) = brr '放数据区域
End With
MsgBox "汇总完成。"
End If
Application.ScreenUpdating = True '恢复屏幕更新
End Sub
---------------------------------------------------------------------------------------------
指定名称批量创建工作簿：
Sub Createwks()
Dim i&, p$, r
Application.ScreenUpdating = False
'取消屏幕刷新
Application.DisplayAlerts = False
'取消警告提示，当有重名工作簿时直接覆盖
p = ThisWorkbook.Path & "\"
'当前工作簿所在的路径
r = [a1].CurrentRegion '数据装入数组r
For i = 2 To UBound(r)
'标题不要，因此从第2个元素开始遍历数组r
With Workbooks.Add '新建工作簿
.SaveAs p & r(i, 1), xlWorkbookDefault
'保存工作簿
.Close True
'关闭工作簿
End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
=INDEX(GET.WORKBOOK(1),ROW(目录!B4))&T(NOW())
=IFERROR(HYPERLINK(目录&"!A1",MID(目录,FIND("]",目录)+1,99)),"")
2.excel制作文件目录:方法二
=MID(GET.WORKBOOK(1),FIND("]",GET.WORKBOOK(1))+1,99)&T(NOW())
=IFERROR(HYPERLINK("#"&INDEX(Shname,ROW(A1))&"!a1",INDEX(Shname,ROW(A1))),"")
3.合并excel工作表:
=MID(GET.WORKBOOK(1),FIND("]",GET.WORKBOOK(1))+1,99)&T(NOW())
=INDEX(sh,INT((ROW(A1)-1)/6)+1)
=INDIRECT($A11&"!"&ADDRESS(COUNTIF($A$1:$A11,$A11)+1,COLUMN(A10)))
4.批量选择数据的明细:
=OFFSET('4449'!$B$3,0,0,MATCH((LOOKUP("座",'4449'!$C:$C)),'4449'!$C:$C,0)-2,2)
5.Indirect函数:=IFERROR(SUM(INDIRECT(A5&"!B:B")),"")
6.match函数:
7.Index函数:
8.vlookup函数:
9.hlookup函数
10.lookup函数:
11.round函数:
12.sumif函数:
13.sumifs函数:
14.SUMPRODUCT函数:
-------------------------------------------------------------------------------------------------------------------------------
1、制作excel文件目录：
步骤一:点击“公式”—定义名称“目录”—输入“=INDEX(GET.WORKBOOK(1),ROW(目录!B1))&T(NOW())”
步骤二：在目录工作表中输入“=IFERROR(HYPERLINK(目录&"!A1",MID(目录,FIND("]",目录)+1,99)),"")”，向下填充，有多少工作表填充多少行。
方法二：在工作表任意单元格中录入“=目录”，在相邻单元个录入“HYPERLINK("#"&A1&"!a1","点击跳转")”—向下填充
PS：返回目录：在出目录以为的工作表中的任意单元格输入“=HYPERLINK("#目录！a1","返回目录")”
2、取得硬盘指定目录下文件名
步骤一：新建一空白的Excel文件—“在A2单元格中设置数据验证”—“数据验证”— “序列”—“来源”处输入“*.*,*.xls,*.doc”
步骤二：定义名称"路径"—输入“=MID(CELL("filename"),1,FIND("[",CELL("filename"),1)-1)”
步骤三：定义名称“分类”—输入“=FILES(路径&目录!$A$2)&T(NOW())”
步骤四：在单元格B2中输入“=IF(ROW()-1>COUNTA(分类),"",HYPERLINK(路径&INDEX(分类,ROW(1:1)),INDEX(分类,ROW(1:1)))) "
注：工作表必须保存为启用宏的工作表。
3、制作动态下拉菜单
步骤：点击”公式”—“定义名称”—“输入$A$2:INDEX($A:$A,counta($A:$A))”
4、制作动态二级菜单
步骤一：定义名称：“区域”—输入“OFFSET($A$1,,,,COUNTA($1:$1))”
步骤二：定义名称：“姓名”—输入“OFFSET($A$2,,MATCH($B2,$1$1,)-1,COUNTA(OFFSET($A$2,,MATCH($B2,$1$1,)-1,100)))”
5、合并Excel工作表
步骤一：定义公式名称"SH"—输入"MID(GET.WORKBOOK(1),FIND"]",GET.WORKBOOK(1))+1,99)&T(NOW())"
步骤二：在A列输入"INDEX(SH,INT((ROW(A1)-1)/6)+1)"
步骤三：在B2中输入"INDIRECT($A2&"!"&ADDRESS(COUNTIF($A$1:$A2,$A2)+1,COLUMN(A1)))"
注：工作表必须保存为启用宏的工作表。
6、LOOK UP函数的经典用法
查找最后一条符合条件的记录：=LOOKUP(1,0/(条件区域=条件)，查询区域)
查找符合多个条件的记录：=LOOKUP(1,0/((条件区域1=条件1)* (条件区域2=条件2))，查询区域)
查找符合多个条件的记录:LOOKUP(1,0/((A12=$A$2:$A$9)*(B12=$C$2:$C$9)),$E$2:$E$9
逆向查找：LOOKUP(1,0/(B4:B11="A3",A4:A11)
逆向查找：LOOKUP(1,0/(E2=$B$2:$B$10,$A$2:$A$10)
LOOKUP(1,0/(条件区域<>""),查询区域)
查询A列的最后一个文本：=lookup("座",A:A)或者=lookup("々",A:A)
查询A列的最后一个数字：=lookup(9E307,A:A)
查询A列的最后一个单元格内容：=lookup(1,0/(A:A<>""),A:A)
查找最后一个非空值：LOOKUP(1,0/(B2:B13<>""),$A2:$A13)
单条件查找：LOOKUP(1,0/($B$2:$B$17=$H2),C$2:C$17)
双条件查找：LOOKUP(1，0/($A$2:$A$17=$M2)*($B$2:$17=$N2)),C$2:C$17)
区间查找：LOOKUP(F3，B$3:B$11，C$3:C$11)
一般查找：LOOKUP(1,0/(b2:b6=b9),e2:e6)
根据名称查找类别：LOOKUP(1,0/($B$2:$B$17=T2),$A$2:$A$17)
对合并类别单元格一一对应名称：LOOKUP(1,0/($A$23:A23<>""),$A$23:A23)
模糊查找：LOOKUP(9^9,FIND(A7,A$6:A10),B$3:B$6)
模糊查找：LOOKUP(9^9,find(A$3:A$6,A10),B$3:B$6)
关键字：LOOKUP(9^9,FIND(查找值,查找单元格),查找区域)
数字提取：
数字在开头:LOOKUP(9^9,LEFT(B1,ROW(1:9))*1)
数字在结尾:LOOKUP(9^9,RIGHT(B1,ROW(1:9))*1)
数字在任意位置:{=LOOKUP(9^9,MID(A1,MATCH(1,MID(A1,ROW(1:9),1)^0,0),ROW(1:9))*1)}
{=MATCH(,-FIND(ROW(A:A)%,A1))%}(方法二)
7、提取不重复的数据
=IFERROR(INDEX(A$2:A$13,MATCH(,COUNTIF(D$1:D1,A$2:A$13),)), "")
将满足条件的放同一个单元格：
=MID(SUBSTITUTE(PHONETIC(OFFSET(A$1,MATCH(D2,A$2:A$13,),,COUNTIF(A$2:A$13,D2),2)),D2, "、")2,99)
8、条件格式
突出显示重复值
=COUNTIF(A$2:A2,A2)>1
突出显示最小值
=B4=MIN($B4:$F4)
9、VLOOKUP函数
模糊查找：=VLOOKUP("*"&A10&"*",A2:B6,2,0)
多条件查找：=VLOOKUP(B9&C9,IF{1,0},B2:B6&A2:A6,E2:E6,2,0)按Ctrl+shift+enter
多表查找：=IFERROR(VLOOKUP(A2,服务!A:G,7,0),IFERROR(VLOOKUP(A2,人事!A:G,7,0), IFERROR(VLOOKUP(A2,综合!A:G,7,0),IFERROR(VLOOKUP(A2,财务!A:G,7,0), IFERROR(VLOOKUP(A2,销售!A:G,7,0), "无此人信息")))))
方法二：VLOOKUP(A2,INDIRECT(LOOKUP(1,0/COUNTIF(INDIRECT({"销售";"服务";"人事";"综合";"财务"}&"!A:A"),A2),{"销售";"服务";"人事";"综合";"财务"}&"!A:A")& "!A:G")7,0)
一对多查找：A2=B2&COUNTIF(B$1:B2,B2)
B11=IFERROR(VLOOKUP($A11&COLUMN(A1),$A:$C,3,0), "")
一对多查找:VLOOKUP(B$9&ROW(A1),IF{1,0},$B$2:$B$6&COUNTIF(INDIRECT("b2:b"&ROW($2:$6)),B$9),$C$2:$C$6,2,)
按Ctrl+shift+enter
10、隔列求和
有标题：SUMIFS($A$2:$G$2,H$2,A3:G3)没有标题:=SUMPRODUCT((MOD(COLUMN(B3:G3),2)=0)*B3:G3)
=SUM(VLOOKUP(A3,A3:G3,ROW(1:3)*2,0))
多条件模糊求和：=SUMIFS(C2:C7,A2:A7,A11&"*",B2:B7,B11)
SUMPRODUCT(ISNUMBER(FIND(A11,A2:A7))*(B2:B7=B11)*C2:C7))
多表求和：=sum(sheet1:sheet20!b2)
多列条件求和:
=SUMPRODUCT(SUMIF(OFFSET(B3:B8,,ROW(1:8)*0),B11,OFFSET(B3:B8,,ROW(1:8)*0),B11,OFFSET(B3:B8,,ROW(1:8))))=SUMPRODUCT(SUBTOTAL(9,OFFSET(C2:J2,ROW(1:6),))*(B3:B8=B11))
=SUMPRODUCT(MMULT(C3:J8,ROW(1:8)^0)*(B3:B8=B11))
多表合并：INDIRECT(B$1&"!B"&ROW())
多表汇总：=SUMPRODUCT(SUMIF(INDIRECT(ROW($1:$5)& "!B:B"),A2,INDIRECT(ROW($1:$5) "!C:C")))
11、小写转换大写
1 =SUBSTITUTE(SUBSTITUTE(TEXT(TRUNC(FIXED(A2)),"[>0][dbnum2]G/通用格式元;[<0]负[dbnum2]G/通用格式元;;")&TEXT(RIGHT(FIXED(A2),2),"[dbnum2]0角0分;;"&IF(ABS(A2)>1%,"整",)),"零角",IF(ABS(A2)<1,,"零")),"零分","整")
2 =SUBSTITUTE(SUBSTITUTE(IF(A2>-0.5%,,"负")&TEXT(INT(FIXED(ABS(A2))),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(FIXED(A2),2),"[dbnum2]0角0分;;"&IF(ABS(A2)>1%,"整",)),"零角",IF(ABS(A2)<1,,"零")),"零分","整")
3 =SUBSTITUTE(SUBSTITUTE(IF(A2>-0.5%,,"负")&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(FIXED(A2),2),"[dbnum2]0角0分;;"&IF(ABS(A2)>1%,"整",)),"零角",IF(ABS(A2)<1,,"零")),"零分","整")
4 =SUBSTITUTE(SUBSTITUTE(IF(A2>-0.5%,,"负")&TEXT(INT(FIXED(ABS(A2))),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(FIXED(A2),2),"[dbnum2]0角0分;;"&IF(ABS(A2)>1%,"整",)),"零角",IF(ABS(A2)<1,,"零")),"零分","整")
5 =SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(IF(A2>-0.5%,,"负")&TEXT(INT(FIXED(ABS(A2))),"[dbnum2]")&TEXT(RIGHT(FIXED(A2),2),"[dbnum2]元0角0分;;元"&IF(ABS(A2)>1%,"整",)),"零角",IF(ABS(A2)<1,,"零")),"零元",),"零分","整")
6 =SUBSTITUTE(SUBSTITUTE(IF(A2>-0.5%,,"负")&IF(ABS(A2)+0.5%<1,,TEXT(INT(ABS(A2)+0.5%),"[dbnum2]")&"元")&TEXT(RIGHT(FIXED(A2),2),"[dbnum2]0角0分;;"&IF(ABS(A2)>1%,"整",)),"零角",IF(ABS(A2)<1,,"零")),"零分","整")
7 =IF(A2=0,"零",IF(A2>-0.5%,,"负")&TEXT(INT(ABS(A2)),"[dbnum2]G/通用格式元;;")&SUBSTITUTE(SUBSTITUTE(TEXT(RIGHT(FIXED(A2),2),"[dbnum2]0角0分;;"),"零角",IF(ABS(A2)<1,,"零")),"零分","整"))
8 =SUBSTITUTE(SUBSTITUTE(TEXT(TRUNC(FIXED(A2)),"[dbnum2]G/通用格式元;负[dbnum2]G/通用格式元;"&IF(A2>-0.5%,,"负"))&TEXT(RIGHT(FIXED(A2),2),"[dbnum2]0角0分;;"&IF(ABS(A2)>1%,"整",)),"零角",IF(ABS(A2)<1,,"零")),"零分","整")
9 =SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(IF(B8<0,"负",)&TEXT(INT(ABS(B8)),"[dbnum2];; ")&TEXT(MOD(ABS(B8)*100,100),"[>9][dbnum2]圆0角0分;[=0]圆整;[dbnum2]圆零0分"),"零分","整")," 圆零",)," 圆",)
10 =SUBSTITUTE(SUBSTITUTE(TEXT(INT(A1),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(A1/1%,2),"[dbnum2]0角0分;;"&IF(A1,"整",)),"零角","零"),"零分","整")
"大写（人民币）："&IF(A1-INT(A1)<0.005,TEXT(INT(A1),"[dbnum2]")&"元整",IF(A1*10-INT(A1*10)<0.05,TEXT(INT(A1),"[dbnum2]")&"元"&TEXT(INT(A1*10-INT(A1)*10),"[dbnum2]")&"角整",TEXT(INT(A1),"[dbnum2]")&"元"&TEXT(INT(A1*10-INT(A1)*10),"[dbnum2]")&"角"&TEXT((FIXED(A1*100,0)-INT(A1*10)*10),"[dbnum2]")&"分"))
11 =IF(ABS(A2)<0.5%,"",SUBSTITUTE(SUBSTITUTE(IF(A2<0,"负",)&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(FIXED(A2),2),"[dbnum2]0角0分;;整"),"零角",IF(ABS(A2)<1,,"零")),"零分","整"))
12 =SUBSTITUTE(SUBSTITUTE(IF(A1>-0.5%,,"负")&TEXT(INT(ABS(A1)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A1),2),"[dbnum2]0角0分;;"&IF(ABS(A1)>1%,"整",)),"零角",IF(ABS(A1)<1,,"零")),"零分","整")
13 =IF(ABS(A2)<0.5%,"",SUBSTITUTE(SUBSTITUTE(IF(A2<0,"负",)&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2),2),"[dbnum2]0角0分;;整"),"零角",IF(ABS(A2)<1,,"零")),"零分","整"))
14 =IF(-RMB(A2),SUBSTITUTE(SUBSTITUTE(IF(A2<0,"负",)&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2),2),"[dbnum2]0角0分;;整"),"零角",IF(ABS(A2)<1,,"零")),"零分","整"),"")
15 =SUBSTITUTE(IF(-RMB(A2),IF(A2<0,"负",)&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2),2),"[>9][dbnum2]0角0分;[>][dbnum2]0分;整"),""),"零分","整")
16 =SUBSTITUTE(IF(-RMB(A2),IF(A2<0,"负",)&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2),2),"[>9][dbnum2]0角0分;零[>][dbnum2]0分;整"),""),"零分","整")
17 =SUBSTITUTE(SUBSTITUTE(IF(-RMB(A1),IF(A1<0,"负",)&TEXT(INT(ABS(A1)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A1),2),"[dbnum2]0角0分;;整"),),"零角",IF(ABS(A1)<1,,"零")),"零分","整")
18 =TEXT(RMB(A1),"[=]g;"&TEXT(INT(ABS(A1)+0.5%),"[dbnum2]G/通用格式元;;")&SUBSTITUTE(SUBSTITUTE(TEXT(RIGHT(RMB(A1),2),"[dbnum2]0角0分;;整"),"零角",IF(ABS(A1)<1,,"零")),"零分","整"))
19 SUBSTITUTE(IF(-RMB(A2),IF(A2<0,"负",)&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2),2),"[>9][dbnum2]0角0分整;"&IF(ABS(A2)<1,,0)&"[>][dbnum2]0分;整"),),"零分",)
20 =SUBSTITUTE(IF(-RMB(A2),IF(A2>0,,"负")&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2),2),"[>9][dbnum2]0角0分;"&IF(A2^2<1,,0)&"[>][dbnum2]0分;整"),),"零分","整")
21 =SUBSTITUTE(SUBSTITUTE(IF(-RMB(A2),IF(A2>0,,"负")&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2),2),"[dbnum2]0角0分;;整"),),"零角",IF(A2^2<1,,"零")),"零分","整")
22 =SUBSTITUTE(IF(-RMB(A2),IF(A2<0,"负",)&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2),2),"[>9][dbnum2]0角0分整;"&IF(A2^2<1,,0)&"[>][dbnum2]0分;整"),),"零分",)
23 =TEXT(A2,";负")&SUBSTITUTE(TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&IF(-RMB(A2),TEXT(RIGHT(RMB(A2),2),"[>9][dbnum2]0角0分整;"&IF(A2^2<1,,0)&"[>][dbnum2]0分;整"),),"零分",)
24 =TEXT(RMB(A1),"[=]g;"&TEXT(INT(ABS(A1)+0.5%),"[dbnum2]G/通用格式元;;")&SUBSTITUTE(SUBSTITUTE(TEXT(RIGHT(RMB(A1),2),"[dbnum2]0角0分;;整"),"零角",IF(A1^2<1,,"零")),"零分","整"))
25 =SUBSTITUTE(IF(-RMB(A2),TEXT(A2,";负")&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2),2),"[>9][dbnum2]0角0分;"&IF(A2^2<1,,0)&"[>][dbnum2]0分;整"),),"零分","整")
26 =SUBSTITUTE(SUBSTITUTE(IF(-RMB(A2,2),TEXT(A2,";负")&TEXT(INT(ABS(A2)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(A2,2),2),"[dbnum2]0角0分;;整"),),"零角",IF(A2^2<1,,"零")),"零分","整")
27 =TEXT(LEFT(RMB(A1),LEN(RMB(A1))-3),"[>0][dbnum2]G/通用格式元;[<0]负[dbnum2]G/通用格式元;;") & TEXT(RIGHT(RMB(A1),2),"[dbnum2]0角0分;;整")
28 TEXT(INT(A3),"[dbnum2]")&"元"&IF(INT(A3*10)-INT(A3)*10=0,"",TEXT(INT(A3*10)-INT(A3)*10,"[dbnum2]")&"角")&IF(INT(A3*100)-INT(A3*10)*10=0,"整",TEXT(INT(A3*100)-INT(A3*10)*10,"[dbnum2]")&"分")
29 =IF(OR(B1="",B1=0),"",TEXT(INT(B1,"[dbnum2]G/通用格式元;[dbnum2]G/通用格式元;;")&TEXT(--RIGHT(INT(B1*10)),"[dbnum2]#角;;;")&TEXT(--RIGHT(INT(B1*100)),"[dbnum2]#分;;整;"))
--------------------------------------------------------------------------------------------
12、SUBSTITUTE常用方法
例1：=SUBSTITUTE(B2, "A", "B")
例2：=SUBSTITUTE(B2，MID(B2,4,5), "*****")
例3：数据分列：=TRIM(MID(SUBSTITUTE($B2, "、",REPT("",100)),COLUMN(A1)*100-99,100))
例4：=SUMPRODUCT(--SUBSTITUTE(B2:B6,"人",))
13、阶梯电价的计算方式
=SUM(TEXT(A2-{0,260,600}, "0;!0")*{0.68,0.05,0.25})
14、按指定次数重复数据：
=IFERROR(VLOOKUP(ROW(A1),A:B,2，0),E3)&""
15、offset的用法：
下拉菜单：=OFFSET($C$1，MATCH(A2&"*",C:C,0)-1,,COUNTAIF(C:C,A2&"*"),1)
动态图表的制作：
定义名称：日期=OFFSET($A$1,COUNT($A:$A),0,-7)
定义名称：销售额=OFFSET($B$1,COUNT($A:$A),0,-7)
分组求和：=SUM(OFFSET($A2,,(COLUMN()-COLUMN($M$1))*3,,3))
间隔取值：OFFSET($A2,,(COLUMN()-COLUMN($M$1))*3,,1)
动态确定求和的数据区域：=SUMIF($A:$A,$O2,OFFSET($A:$A,,MATCH(P$1,$B$1:$M$1,0)))
动态显示最近几天的总数量：
=SUM(OFFSET(B1，COUNT(B:B)-D2+1,,D2))
=SUM(OFFSET(B1,COUNTA(B:B),,-D2))
创建二级下拉菜单：
一级菜单=OFFSET(二级下拉菜单$A$1,1,,COUNTA(二级下拉菜单$A:$A)-1)
二级菜单=OFFSET(二级下拉菜单$B$1,MATCH(二级下拉菜单G2,一级菜单,0),,,COUNTA(OFFSET(二级下拉菜单$B$1:$E$1,MATCH(二级下拉菜单G2,一级菜单，0),)))
创建动态数据透视表：
=OFFSET(动态的数据透视表$A:$1,,,COUNTA(动态的数据透视表$A:$A),COUNTA(动态的数据透视表$1:$1))
Excel多表相同项求和
1、 定义名称：SH=MID(GET.WORKBOOK(1),FIND("]",GET.WORKBOOK(1)+1,99)&T(NOW())
2、 求和：=SUMPRODUCT((SUMIF(INDIRECT(SH&”!b:b”),D2,INDIRECT(SH&"!C:C"))))
Excel双向查找：
1、 =OFFSET($B$2,MATCH(B10,B3:B7,0),MATCH(C10,C2:H2,0))
2、 =INDEX(C3:H7,MATCH(B10,B3:B7,0),MATCH(C10,C2:H2,0))
3、 =VLOOKUP(B10,$B$3:$H$7,MATCH(C10,$C$2:$H$2,0)+1,0)
4、 =INDIRECT(ADDRESS(MATCH(B10,B1:B7,0),MATCH(C10,A2:H2,0),,,"sheet1"))
5、 =HLOOKUP(C10,C2:H7,MATCH(B10,B2:B7,0),0)
6、 =LOOKUP(1,0/(B10=B2:B7),OFFSET(B2:B7,,MATCH(C10,B2:H2,0)-1,))
7、 =SUMPRODUCT(($B$3:$B$7=B10)*($C$2:$H$2=C10)*$C$3:$H$7)
8、 =SUM((B3:B7=B10)*(C2:H2=C10)*(C3:H7)) 数组公式
9、 =MAX((B3:B7=B10)*(C2:H2=C10)*(C3:H7))
Look up高级用法
--------------------------------------------------------------------------------------------
数字在开头
A1的值为 123.45ABC
公式：
=LOOKUP(9^9,LEFT(B1,ROW(1:9))*1)
截取结果：123.45
数字在结尾
A1的值为 ABC123.45
公式： =LOOKUP(9^9,RIGHT(B1,ROW(1:9))*1)
截取结果：123.45
----------------------------------------------------------------------------------------------
数字在任意位置。
A1的值为 ABC123.45FE
数组公式：{=LOOKUP(9^9,MID(A1,MATCH(1,MID(A1,ROW(1:9),1)^0,0),ROW(1:9))*1)}
截取结果：123.45
其他公式1： =LOOKUP(9E+307,--MID(F72,MIN(FIND({0;1;2;3;4;5;6;7;8;9},A1&1234567890)),ROW(INDIRECT("1:"&LEN(F72)))))
其他公式2：=SUM(MID(0&F72,1+LARGE(ISNUMBER(-MID(F72,ROW($1:$32),1))*ROW($1:$32),ROW($1:$15)),1)*10^ROW($2:$16))%（混合字符）——备注：颜色标记部分，可根据提取单元格字符长短修改
其他公式3=IF(LEN(MID(SUM(MID("01"&F72,1+LARGE(ISNUMBER(-MID(1&F72,ROW($1:$50),1))*ROW($1:$50),ROW($1:$15)),1)*10^ROW($2:$16))%,2,99))>=8,RIGHT(LEFT(MID(SUM(MID("01"&F72,1+LARGE(ISNUMBER(-MID(1&F72,ROW($1:$50),1))*ROW($1:$50),ROW($1:$15)),1)*10^ROW($2:$16))%,2,99),8),4),0)
--------------------------------------------------------------------------------------------
表格核对
1、开始—条件格式—使用公式确定——（引用单元格=cell（"contents"））—突出显示差异单元格
2、同行数据对比：选中两列——按CTLR+\
3、相同数值不同行（单列无重复值）：条件格式—突出显示单元格规则—重复值
4、相同数值不同行（单列有重复值）：数据—高级筛选—列表区域（一列）——条件区域（另一列）——确定
5、不同工作表核对：=countif（工作表1A:A,A2）—通过数据筛选——筛选大于0的
6、多表核对：使用多条件就和做差法
7、两个表格数值类型对比：使用选择性粘贴—减的方法核对
8、不限数值类型对比：开始—条件格式—使用公式确定—输入“A2<>C2”—用颜色标记出
9、位置不同的两表核对：开始—条件格式—使用公式确定—输入“Vlookup($H11,$H$2:$N$8,COLUMN()-7,0)”—用颜色标记出
=LOOKUP(9E+307,--MID(H2,MIN(FIND({0;1;2;3;4;5;6;7;8;9},H2&1234567890)),ROW(INDIRECT("1:"&LEN(H2)))))
=========================================================================
VBA:
1. Sub BalanceCalculate()
Dim ws As Worksheet, n
For Each ws In Worksheets
For n = 5 To [A1048576].End(xlUp).Row
If ws.Name = Cells(n, 1) Then
a = ws.[f1048576].End(xlUp)
Sheet2.Cells(n, 9) = a
End If
Next
Next
End Sub
--------------------------------------------------------------------------------------------
2. Sub Dataclassification()
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name = Sheets("数据汇总").Range("h2") Then
'Rs = ws.UsedRange.Rows.Count + 1
Sheets("数据汇总").Select
ends = ws.[a:a].Find("*", searchdirection:=xlPrevious).Row + 1
Range("i4", [M1048576].End(xlUp)).Copy ws.Cells(ends, 1)
End If
Next
End Sub
--------------------------------------------------------------------------------------------
3.Sub DataImport()
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Users\Administrator\Desktop\2015.txt", Destination:=Range("$A$1"))
' .CommandType = 0
.Name = "2015_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 936
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "^"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
--------------------------------------------------------------------------------------------
4. Sub Datasearch()
Dim rng As Range, i
i = 3
j = 2
ends = Sheets("数据汇总").[a:a].Find("*", searchdirection:=xlPrevious).Row
For Each rng In Range("a5:a" & ends)
i = i + 1
If rng Like Range("H2") Then
j = j + 1
Range("a" & i + 1 & ":e" & i + 1).Copy Range("h" & j + 1)
End If
Next
End Sub
--------------------------------------------------------------------------------------------
5.制作目录
Sub Index()
Dim ws As Worksheet, i
i = 3
Sheets("目录").Cells(3, 3) = "目录"
For Each ws In Worksheets
If ws.Name <> "目录" Then
Sheets("目录").Cells(i, 3) = ws.Name
End If
i = i + 1
Next
End Sub
--------------------------------------------------------------------------------------------
6.查询
Sub IndexExchangeDetail()
Dim ws As Worksheet
If Cells(4, 7) = "" Then
MsgBox "请输入需要查询的账户"
End If
For Each ws In Worksheets
If Cells(4, 7) = ws.Name Then
ws.Select
ws.Range([d3], [e1048576].End(xlUp)).Select
End If
Next
End Sub
--------------------------------------------------------------------------------------------
7.查询
Sub IndexRevenueDetail()
Dim ws As Worksheet
If Cells(4, 4) = "" Then
MsgBox "请输入需要查询的账户"
End If
For Each ws In Worksheets
If Cells(4, 4) = ws.Name Then
ws.Select
ws.Range([b3], [C1048576].End(xlUp)).Select
End If
Next
End Sub
--------------------------------------------------------------------------------------------8.合并工作表
Sub Marge()
Dim i%, rs%, rss%, st As Worksheet, zst As Worksheet
Set zst = Sheets("汇总表")
For i = 3 To 5
Set st = Sheets(i)
rs = st.UsedRange.Rows.Count
rss = zst.UsedRange.Rows.Count + 1
st.Range("a2:g" & rs).Copy zst.Cells(rss, 1)
zst.Cells(rss, 7).Resize(rs - 1) = i
Next
End Sub
-------------------------------------------------------------------------------------------
9.PaidoutCalculate
Sub PaidoutCalculate()
Dim ws As Worksheet, n
Sum = 0
For Each ws In Worksheets
For n = 5 To [A1048576].End(xlUp).Row
If ws.Name = Cells(n, 1) Then
For i = 3 To ws.[d1048576].End(xlUp).Row
Sum = Sum + ws.Cells(i, 4)
Next
Sheet2.Cells(n, 6) = Sum
Sum = 0
End If
Next
Next
End Sub
--------------------------------------------------------------------------------------------
10.RevenueCalculate
Sub RevenueCalculate()
Dim ws As Worksheet, n
Sum = 0
For Each ws In Worksheets
For n = 5 To [A1048576].End(xlUp).Row
If ws.Name = Cells(n, 1) Then
For i = 3 To ws.[b1048576].End(xlUp).Row
Sum = Sum + ws.Cells(i, 2)
Next
Sheet2.Cells(n, 3) = Sum
Sum = 0
End If
Next
Next
End Sub
--------------------------------------------------------------------------------------------
11.窗体显示
Sub ShowRevenueData()
PaidoutData.Show
End Sub
----------------------
Sub ShowRevenueData()
RevenueData.Show
End Sub
--------------------------------------------------------------------------------------------
12.拆分工作表
Sub Split()
For i = 3 To 5
Worksheets.Add.Name = i
For Each rng In Sheets("汇总表").Range("g2:g540")
If rng.Value = i Then
n = "g" & rng.Row & ":a" & rng.Row
y = y + 1
If y = 3 Then
Sheets("汇总表").Range("a1:d1").Copy Sheets(i).Cells(y, 1)
End If
Sheets("汇总表").Range(n).Copy Sheets(i).Cells(y + 1, 1)
End If
Next
y = 0
Next
End Sub
--------------------------------------------------------------------------------------------
13.工作表密码破解
Sub unprotect() '破解excel密码
Dim ws As Worksheet
For Each ws In Worksheets
ws.Protect AllowFiltering:=True
ws.unprotect
End Sub
--------------------------------------------------------------------------------------------
14.RevenueData
Private Sub Cancel_Click()
Unload RevenueData
End Sub
---------------------------
Private Sub OK_Click()
Dim ws As Worksheet, n
If TextBox1 = "" And TextBox2 = "" And TextBox3 = "" And TextBox4 = "" Then
MsgBox "请输入数据,然后再点击增加"
End If
For Each ws In Worksheets
If TextBox1.Value = ws.Name Then
ws.Activate
ends = Columns(1).Find("*", , , , , searchdirection:=xlPrevious).Row
Cells(ends + 1, 1) = TextBox2.Value
Cells(ends + 1, 2) = TextBox3.Value
Cells(ends + 1, 3) = TextBox4.Value
' ws.[A1048576].End(xlUp)(1, 0) = TextBox2.Value
' ws.[A1048576].End(xlUp)(1, 1) = TextBox3.Value
' ws.[A1048576].End(xlUp)(1, 2) = TextBox4.Value
MsgBox "数据添加完成!"
End If
Next
Unload RevenueData
MsgBox "您已退出系统,欢迎再次使用"
End Sub
--------------------------------------------------------------------------------------------
15.用户登录界面
Private Sub Cancel_Click()
Unload Login
End Sub
=============================
Private Sub OK_Click()
If TextBox1 = "admin" And TextBox2 = "123456" Then
MsgBox "登录成功,欢迎使用本系统"
Unload Login
Application.Visible = True
Else
MsgBox "用户或密码不正确,请您核实之后重新输入"
ThisWorkbook.Application.Quit
End If
End Sub
--------------------------------------------------------------------------------------------
一键生成带目录的超链接：
Sub ml()
Dim sht As Worksheet, i&, shtname$
Columns(1).ClearContents '清空A列数据
Cells(1, 1) = "目录"
'第一个单元格写入字符串"目录"
i = 1
'将i的初值设置为1.
For Each sht In Worksheets
'循环当前工作簿的每个工作表
shtname = sht.Name
If shtname <> ActiveSheet.Name Then
'如果sht的名称不是当前工作表的名称则开始在当前工作表建立超链接
i = i + 1
'累加i
ActiveSheet.Hyperlinks.Add anchor:=Cells(i, 1), Address:="",SubAddress:="'" & shtname & "'!a1",TextToDisplay:=shtname
'建超链接
End If
Next
End Sub
--------------------------------------------------------------------------------------------
一键批量取消隐藏工作表：
Sub qxyc()
Dim sht As Worksheet
'定义变量
For Each sht In Worksheets
'循环工作簿里的每一个工作表
sht.Visible = xlSheetVisible
'将工作表的状态设置为非隐藏
Next
End Sub
--------------------------------------------------------------------------------------------
批量该工作表名称：
Sub rename()
Dim shtname$, sht As Worksheet, i&
On Error Resume Next
'当程序运行中出现错误时，继续运行
For i = 1 To Cells(Rows.Count, 1).End(3).Row
'遍历当前表格A列的数据
shtname = Cells(i, 1)
'将表格A列的值，赋予变量shtname
'之所以将shtname的变量类型定义为文本，是防止A列数据为数值时和sheet序列引用产生冲突。
Set sht = Sheets(shtname)
If Err = 0 Then
'如果工作簿存在sht表，则更名
Sheets(shtname).Name = Cells(i, 2)
Else
'如果工作薄不存在sht表，则清除错误，对下一个值判断处理
Err.Clear
End If
Next
End Sub
--------------------------------------------------------------------------------------------
提取工作表名称：
Sub ml()
Dim sht As Worksheet, k&
[a:a] = ""
'清空A列数据
[a1] = "目录"
k = 1
For Each sht In Worksheets
'遍历工作簿中每个工作表
k = k + 1
'累加K值
Cells(k, 1) = sht.Name
'将工作表名称依次放入表格A列
Next
End Sub
--------------------------------------------------------------------------------------------
重新排序工作表
Sub sortsheet()
Dim sht As Worksheet, shtname$, i&
Set sht = ActiveSheet
'设置变量sht为当前激活的工作表，即目录表。
For i = 2 To sht.Cells(Rows.Count, 1).End(3).Row
'遍历工作表A列的数据，A1以外。
shtname = sht.Cells(i, 1)
'将A列值赋值为字符串变量shtname
Sheets(shtname).Move after:=Sheets(i- 1)
'将工作表依次移动
Next
sht.Activate
'重新激活目录表
End Sub
--------------------------------------------------------------------------------------------
一键汇总个分表数据到总表
Sub collect()
'VBA编程学习与实践，一键多表数据汇总
Dim sht As Worksheet, rng As Range, k&, trow&
Application.ScreenUpdating = False
'取消屏幕更新，加快代码运行速度
trow = Val(InputBox("请输入标题的行数", "提醒"))
If trow < 0 Then MsgBox "标题行数不能为负数。", 64, "警告": Exit Sub
'取得用户输入的标题行数，如果为负数，退出程序
Cells.ClearContents
'清空当前表数据
For Each sht In Worksheets
'循环读取表格
If sht.Name <> ActiveSheet.Name Then
'如果表格名称不等于当前表名则进行汇总动作……
Set rng = sht.UsedRange
'定义rng为表格已用区域
k = k + 1
'累计K值
If k = 1 Then
'如果是首个表格，则K为1，则把标题行一起复制到汇总表
rng.Copy
[a1].PasteSpecial Paste:=xlPasteValues
Else
'否则，扣除标题行后再复制黏贴到总表，只黏贴数值
rng.Offset(trow).Copy
Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1).PasteSpecial Paste:=xlPasteValues
End If
End If
Next
[a1].Activate
'激活A1单元格
Application.ScreenUpdating = True
'恢复屏幕刷新
End Sub
--------------------------------------------------------------------------------------------
指定名称批量建立工作表
Sub NewSht()
'ExcelHome VBA编程实践与学习
Dim Sht As Worksheet, Rng As Range
Dim Sn, t$
Set Rng = Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
'将工作表名称所在的单元格区域赋值给变量Rng，单元格A1是标题，不读入
On Error Resume Next
'当代码出错时继续运行
For Each Sn In Rng
'遍历Rng(工作表名称集合）
t = Sn
'还记得这里我们为什么用这句代码吗？
Set Sht = Sheets(t)
'当工作簿不存在工作表Sheets(t)时，这句代码会出错，然后……
If Err Then
'如果代码出错，说明不存在工作表Sheets(t)，则新建工作表
Worksheets.Add , Sheets(Sheets.Count)
'新建一个工作表，位置放在所有已存在工作表的后面
ActiveSheet.Name = t
'新建的工作表必然是活动工作表，为之命名
Err.Clear
'清除错误状态
End If
Next
Rng.Parent.Activate
'重新激活名称数据所在的工作表
End Sub
---------------------------------------------------------------------------------------------
一键拆分总表到个分表
Sub NewShts()
Dim d As Object, sht As Worksheet, arr, brr, r, kr, i&, j&, k&, x&
Dim Rng As Range, Rg As Range, tRow&, tCol&, aCol&, pd&
Application.ScreenUpdating = False '关闭屏幕更新
Application.DisplayAlerts = False '关闭警告信息提示
Set d = CreateObject("scripting.dictionary") 'set字典
Set Rg = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)
'用户选择的拆分依据列
tCol = Rg.Column '取拆分依据列列标
tRow = Val(Application.InputBox("请输入总表标题行的行数？"))
'用户设置总表的标题行数
If tRow = 0 Then MsgBox "你未输入标题行行数，程序退出。": Exit Sub
Set Rng = ActiveSheet.UsedRange '总表的数据区域
arr = Rng '数据范围装入数组arr
tCol = tCol - Rng.Column + 1 '计算依据列在数组中的位置
aCol = UBound(arr, 2) '数据源的列数
For i = tRow + 1 To UBound(arr) '遍历数组arr
If Not d.exists(arr(i, tCol)) Then
d(arr(i, tCol)) = i '字典中不存在关键词则将行号装入字典
Else
d(arr(i, tCol)) = d(arr(i, tCol)) & "," & i '如果存在则合并行号，以逗号间隔
End If
Next
For Each sht In Worksheets '遍历一遍工作表，如果字典中存在则删除
If d.exists(sht.Name) Then sht.Delete
Next
kr = d.keys '字典的key集
For i = 0 To UBound(kr) '遍历字典key值
If kr(i) <> "" Then '如果key不为空
r = Split(d(kr(i)), ",") '取出item里储存的行号
ReDim brr(1 To UBound(r) + 1, 1 To aCol)'声明放置结果的数组brr
k = 0
For x = 0 To UBound(r)
k = k + 1 '累加记录行数
For j = 1 To aCol '循环读取列
brr(k, j) = arr(r(x), j)
Next
Next
With Worksheets.Add(, Sheets(Sheets.Count))
'新建一个工作表，位置在所有已存在sheet的后面
.Name = kr(i) '表格命名
.[a1].Resize(tRow, aCol) = arr '放标题行
.[a1].Offset(tRow, 0).Resize(k, aCol) = brr'放置数据区域
Rng.Copy '复制粘贴总表的格式
.[a1].PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.[a1].Select
End With
End If
Next
Sheets(1).Activate '激活第一个表格
Set d = Nothing '释放字典
Erase arr: Erase brr '释放数组
MsgBox "数据拆分完成！"
Application.ScreenUpdating = True '恢复屏幕更新
Application.DisplayAlerts = True '恢复警示
End Sub
--------------------------------------------------------------------------------------------
批量将工作表转换为工作簿
Sub newbooks()
Dim sht As Worksheet, mypath$
Application.DisplayAlerts = False
'取消显示系统警告和消息
Application.ScreenUpdating = False
'取消屏幕刷新
With Application.FileDialog(msoFileDialogFolderPicker)
'选择保存工作薄的文件路径
.AllowMultiSelect = False
'不允许多选
If .Show Then
mypath = .SelectedItems(1)
'读取选择的文件路径
Else
Exit Sub
'如果没有选择保存路径，则退出程序
End If
End With
If Right(mypath, 1) <> "\" Then mypath = mypath & "\"
For Each sht In Worksheets
'遍历工作表
sht.Copy
'复制工作表，工作表单纯复制后，成为活动工作薄
With ActiveWorkbook
.SaveAs mypath & sht.Name, xlWorkbookDefault
'保存活动工作薄到指定路径下
.Close True '关闭工作薄
End With
Next
MsgBox "处理完成。", , "提醒"
Application.ScreenUpdating = True '恢复屏幕刷新
Application.DisplayAlerts = True '恢复显示系统警告和消息
End Sub
---------------------------------------------------------------------------------------------
将总表分拆各个工作簿：
Sub Newbooks()
Dim d As Object, arr, brr, r, kr, i&, j&, k&, x&
Dim Rng As Range, Rg As Range, tRow&, tCol&, aCol&, pd&, mypath$
Dim Cll As Range, sht As Worksheet
Application.ScreenUpdating = False '取消屏幕刷新
Application.DisplayAlerts = False '取消警告信息提醒，当有重名工作簿时直接覆盖保存。
'
'
'第一部分，用户选择保存分表工作簿的路径。
With Application.FileDialog(msoFileDialogFolderPicker)
'选择保存工作薄的文件路径
.AllowMultiSelect = False
'不允许多选
If .Show Then
mypath = .SelectedItems(1)
'读取选择的文件路径
Else
Exit Sub
'如果没有选择保存路径，则退出程序
End If
End With
If Right(mypath, 1) <> "\" Then mypath = mypath & "\"
'第二部分遍历总表数据，通过字典将指定字段的不同明细行过滤保存
Set d = CreateObject("scripting.dictionary") 'set字典
Set Rg = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)
'用户选择的拆分依据列
tCol = Rg.Column '取拆分依据列列标
tRow = Val(Application.InputBox("请输入总表标题行的行数？"))
'用户设置总表的标题行数
If tRow = 0 Then MsgBox "你未输入标题行行数，程序退出。": Exit Sub
Set Rng = ActiveSheet.UsedRange '总表的数据区域
Set Cll = ActiveSheet.Cells '用于在分表粘贴和总表同样行高列宽的数据格式
arr = Rng '数据范围装入数组arr
tCol = tCol - Rng.Column + 1 '计算依据列在数组中的位置
aCol = UBound(arr, 2) '数据源的列数
For i = tRow + 1 To UBound(arr) '遍历数组arr
If Not d.exists(arr(i, tCol)) Then
d(arr(i, tCol)) = i '字典中不存在关键词则将行号装入字典
Else
d(arr(i, tCol)) = d(arr(i, tCol)) & "," & i '如果存在则合并行号，以逗号间隔
End If
Next
'
'
'第三部分遍历字典取出分表数据明细，建立不同工作簿保存数据。
kr = d.keys '字典的key集
For i = 0 To UBound(kr) '遍历字典key值
If kr(i) <> "" Then '如果key不为空
r = Split(d(kr(i)), ",") '取出item里储存的行号
ReDim brr(1 To UBound(r) + 1, 1 To aCol) '声明放置结果的数组brr
k = 0
For x = 0 To UBound(r)
k = k + 1 '累加记录行数
For j = 1 To aCol '循环读取列
brr(k, j) = arr(r(x), j)
Next
Next
With Workbooks.Add
'新建一个工作簿
With .Sheets(1).[a1]
Cll.Copy '复制粘贴总表的单元格格式
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Resize(tRow, aCol) = arr '放标题行
.Offset(tRow, 0).Resize(k, aCol) = brr '放置数据区域
.Select
End With
.SaveAs mypath & kr(i), xlWorkbookDefault '保存工作簿
.Close True '关闭工作簿
End With
End If
Next
'
'
'收尾巴。
Set d = Nothing '释放字典
Erase arr: Erase brr '释放数组
MsgBox "处理完成。", , "提醒"
Application.ScreenUpdating = True '恢复屏幕刷新
Application.DisplayAlerts = True '恢复显示系统警告和消息
End Sub
--------------------------------------------------------------------------------------------
获取制定文件夹下文件：
Sub FileDir()
Dim p$, f$, k&
'获取用户选择文件夹的路径
With Application.FileDialog(msoFileDialogFolderPicker)
'选择文件夹
.AllowMultiSelect = False
'不允许多选
If .Show Then
p = .SelectedItems(1)
'选择的文件路径赋值变量P
Else
Exit Sub
'如果没有选择保存路径，则退出程序
End If
End With
If Right(p, 1) <> "\" Then p = p & "\"
f = Dir(p & "*.*")
'返回变量P路径下带任意扩展名的文件名。如果超过一个文件存在，函数将返回按条件第一个找到的文件名。
'如果一个文件都没有，则f返回""
[a:a].ClearContents '清空A列数据
[a1] = "目录"
k = 1 'K
Do While f <> "" '如果f不等于""，则……
k = k + 1 '累加K
Cells(k, 1) = f
f = Dir
' 若第二次调用 Dir 函数，但不带任何参数，则将返回同一目录下的下一个文件。
Loop
MsgBox "OK"
End Sub
---------------------------------------------------------------------------------------------
汇总多个工作簿每一个工作表名称包含关键字的数据到总表：
Sub Collectwks()
'ExcelHome VBA编程学习与实践
Dim Sht As Worksheet, Rng As Range, Sh As Worksheet
Dim Trow&, k&, arr, brr, i&, j&, book&, a&
Dim p$, f$, Headr, Keystr
Application.ScreenUpdating = False '关闭屏幕更新
On Error Resume Next '忽略代码运行中可能出现的错误继续运行
'
With Application.FileDialog(msoFileDialogFolderPicker)
'取得用户选择的文件夹路径
.AllowMultiSelect = False
If .Show Then
p = .SelectedItems(1)
Else
Exit Sub
End If
End With
If Right(p, 1) <> "\" Then p = p & "\"
'
Keystr = InputBox("请输入需要合并的工作表所包含的关键词：", "提醒")
If StrPtr(Keystr) = 0 Then Exit Sub
'如果点击了inputbox的取消或者关闭按钮，则退出程序
Trow = Val(InputBox("请输入标题的行数", "提醒"))
If Trow < 0 Then MsgBox "标题行数不能为负数。", 64, "警告": Exit Sub
Set Sht = ActiveSheet
Cells.ClearContents
Cells.NumberFormat = "@"
'清空当前表数据并设置为文本格式
'
f = Dir(p & "*.xls") '开始遍历工作簿
Do While f <> ""
If f <> ThisWorkbook.Name Then '避免同名文件重复打开出错
With GetObject(p & f)
'以'只读'形式读取文件时，使用getobject方法会比workbooks.open稍快
For Each Sh In .Worksheets '遍历表
If InStr(1, Sh.Name, Keystr, vbTextCompare) Then
'如果表中包含关键词则进行汇总(不区分关键词字母大小写）
arr = .Sheets(1).UsedRange '数据区域读入数组arr
book = book + 1 '标记一下是否首个Sheet
If book = 1 Then
ReDim brr(1 To 200000, 1 To UBound(arr, 2) + 1)
'如果是首个表格，则声明一个结果数组,20万行
Headr = Sh.[a1].Resize(Trow, UBound(arr, 2))
'将标题装入数组
a = Trow + 1 '扣掉标题行后的数据区域的开始行
End If
For i = a To UBound(arr) '遍历行
k = k + 1 '累加记录条数
brr(k, UBound(brr, 2)) = Sh.Name '结果数组brr的最后一列装入表名
For j = 1 To UBound(arr, 2) '遍历列
brr(k, j) = arr(i, j)
Next
Next
End If
Next
.Close False '关闭工作簿
End With
End If
f = Dir '下一个表格
Loop
If k > 0 Then
With Sht.[a1]
.Resize(Trow, UBound(Headr, 2)) = Headr '放标题
.Offset(Trow - 1, UBound(Headr, 2)) = "来源表名"
.Offset(Trow).Resize(k, UBound(brr, 2)) = brr '放数据区域
End With
MsgBox "汇总完成。"
End If
Application.ScreenUpdating = True '恢复屏幕更新
End Sub
---------------------------------------------------------------------------------------------
指定名称批量创建工作簿：
Sub Createwks()
Dim i&, p$, r
Application.ScreenUpdating = False
'取消屏幕刷新
Application.DisplayAlerts = False
'取消警告提示，当有重名工作簿时直接覆盖
p = ThisWorkbook.Path & "\"
'当前工作簿所在的路径
r = [a1].CurrentRegion '数据装入数组r
For i = 2 To UBound(r)
'标题不要，因此从第2个元素开始遍历数组r
With Workbooks.Add '新建工作簿
.SaveAs p & r(i, 1), xlWorkbookDefault
'保存工作簿
.Close True
'关闭工作簿
End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub