工作常用
【1】结构调整涉及指标
年报：3-4,205,3701-3706,3711,3712,3735,3745,3751,3781,3782,3784-3786,3821,3831,3861-3863,3871-3876,3881-3883,3891,3900,3907-3910,3920,3941,3945-3947,3955-3957,4202,4203, 4241,4251,4261,4271,4285,4311,4321
季报：3-4,205,1100-1102,1111-1112,1120-1125,1127-1128,1150,1152-1159,1170-1180,1190-1192,1195-1197,2001,2002,2030,2035,2040,2047,2050,2055,2060
评估：2,205,226-227,232-242,556,557-563,62,65,75-76,241-242,352,507-509,512 分析样本结构
季度消费结构：1100-1102,1111-1112,1120-1125,1127-1128,1150-1159,1170-1180,1190-1192,1195-1197,2000-2003,2009,2020,2025,2030,2031-2032,2035-2052,2055,2060
【2】导出问卷，每个值标保留唯一值，且降序排序。
Sub Qsort() Application.ScreenUpdating = False s = UsedRange.Rows.Count For i = 1 To UsedRange.Columns.Count Range(Cells(1, i), Cells(s, i)).RemoveDuplicates 1, xlYes Next For i = 1 To UsedRange.Columns.Count Range(Cells(1, i), Cells(s, i)).Sort Cells(1, i), xlDescending Next End Sub
【3】数据文件加密压缩
VBA★生成bat格式随机密码，并复制到剪切板，在记事本另存.bat即可。
Sub rndpwd()
Randomize (Format(Now(), "yyyymmddhhmmss"))
comb = Split("0,1,2,3,4,5,6,7,8,9,A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z,a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z", ",")
For i = 1 To 11
For j = 0 To 5
s = s & comb(Rnd() * 61)
Next j
k = Format(i, "00")
If i < 11 Then
cs = "RAR.exe a -hp" & s & " -x*610403* 61" & k & "Q1.RAR *61" & k & "* 0*"
Else
cs = "RAR.exe a -hp" & s & " 610403Q1.RAR *610403* 0*"
End If
Cells(i, 1) = cs
cs = "": s = ""
Next i
UsedRange.Copy
End SubBAT★需要将Rar.exe和bat文件放在同一目录，或使用RAR.exe绝对路径。加密、剔除。上面生成的格式如下：
@echo off RAR.exe a -hpIPLmsm 6101Q2data.RAR 0* *6101* RAR.exe a -hpTfrT8s 6102Q2data.RAR 0* *6102* RAR.exe a -hpXzMbg0 6103Q2data.RAR 0* *6103* RAR.exe a -hpii2p4T 6105Q2data.RAR 0* *6105* RAR.exe a -hpn2dx3r 6106Q2data.RAR 0* *6106* RAR.exe a -hp18shFX 6107Q2data.RAR 0* *6107* RAR.exe a -hpops35X 6108Q2data.RAR 0* *6108* RAR.exe a -hpNjsIxG 6109Q2data.RAR 0* *6109* RAR.exe a -hpXwvOq8 6110Q2data.RAR 0* *6110* RAR.exe a -hpZ89l9P -x*610403* 6104Q2data.RAR 0* *6104* RAR.exe a -hpVtOB7P 610403Q2data.RAR 0* *610403* pause
【4】笔记本无线和有线网卡分别上外网、内网时，利用bat快速打开/关闭网卡。
同时使用无线和有线网卡，可以用route命令删除原默认路由，分别添加内网静态路由和默认路由实现。但在实际使用过程中，感觉内外网响应速度都很慢。
route delete 0.0.0.0 route add 192.168.0.0 mask 255.255.255.0 192.168.0.254 -p route add 0.0.0.0 mask 0.0.0.0 10.0.0.254 -p
@echo off :loop echo 1.打开内网 echo 2.打开外网 echo 3.关闭BAT set /p in=请选择(1/2/3): cls if "%in%"=="1" ( netsh wlan disconnect netsh interface set interface 以太网 enabled ) else if "%in%"=="2" ( netsh wlan connect name=CHENZC netsh interface set interface 以太网 disabled ) else if "%in%"=="3" ( exit )else ( echo "请输入1-3！" ) goto loop
【5】同格式excel文件数据合并
Sub sumD() '直接汇总，问题数据显示在sheet2
Application.ScreenUpdating = False
'新建一个对话框对象
Set FolderDialogObject = Application.FileDialog(msoFileDialogFolderPicker)
'配置对话框
With FolderDialogObject
.Title = "请选择要查找的文件夹"
.InitialFileName = "C:\"
End With
'显示对话框
FolderDialogObject.Show
'获取选择对话框选择的文件夹
Set PATHS = FolderDialogObject.SelectedItems
mydir = PATHS(1)
kk = 1
Dim myfile
myfile = Dir(mydir & "\*.*")
i = 1
Do While myfile <> ""
Set dataExcel = CreateObject("Excel.Application")
Set xlbook1 = dataExcel.Workbooks.Open(mydir & "\" & myfile)
Set sheetf = xlbook1.Worksheets(1)
For i = 7 To 9
For j = 6 To 12
If IsNumeric(sheetf.Cells(i, j)) = False Then
Sheet2.Cells(kk, 1) = xlbook1.Name & "-" & i & "-" & j
kk = kk + 1
Else
Cells(i, j) = sheetf.Cells(i, j) + Cells(i, j)
End If
Next j, i
For i = 7 To 23
For j = 13 To 16
If IsNumeric(sheetf.Cells(i, j)) = False Then
Sheet2.Cells(kk, 1) = xlbook1.Name & "-" & i & "-" & j
kk = kk + 1
Else
Cells(i, j) = sheetf.Cells(i, j) + Cells(i, j)
End If
Next j, i
For i = 29 To 35
For j = 13 To 16
If IsNumeric(sheetf.Cells(i, j)) = False Then
Sheet2.Cells(kk, 1) = xlbook1.Name & "-" & i & "-" & j
kk = kk + 1
Else
Cells(i, j) = sheetf.Cells(i, j) + Cells(i, j)
End If
Next j, i
xlbook1.Close False
myfile = Dir
Loop
MsgBox "处理完成，请查看。"
End Sub
Sub sumC() '所有数据复制到sheet2
Application.ScreenUpdating = False
'新建一个对话框对象
Set FolderDialogObject = Application.FileDialog(msoFileDialogFolderPicker)
'配置对话框
With FolderDialogObject
.Title = "请选择要查找的文件夹"
.InitialFileName = "C:\"
End With
'显示对话框
FolderDialogObject.Show
'获取选择对话框选择的文件夹
Set PATHS = FolderDialogObject.SelectedItems
mydir = PATHS(1)
Dim myfile
myfile = Dir(mydir & "\*.*")
i = 1
kk = 1
Do While myfile <> ""
Set dataExcel = CreateObject("Excel.Application")
Set xlbook1 = dataExcel.Workbooks.Open(mydir & "\" & myfile)
Set sheetf = xlbook1.Worksheets(1)
Sheet2.Cells(kk, 1) = xlbook1.Name
ll = 2
For i = 7 To 8
For j = 5 To 14
Sheet2.Cells(kk, ll) = sheetf.Cells(i, j)
ll = ll + 1
Next j, i
For i = 9 To 22
For j = 11 To 14
Sheet2.Cells(kk, ll) = sheetf.Cells(i, j)
ll = ll + 1
Next j, i
For i = 27 To 33
For j = 11 To 14
Sheet2.Cells(kk, ll) = sheetf.Cells(i, j)
ll = ll + 1
Next j, i
xlbook1.Close False
kk = kk + 1
myfile = Dir
Loop
For i = 1 To Sheet2.UsedRange.Rows.Count
For j = 1 To Sheet2.UsedRange.Columns.Count
If IsNumeric(Sheet2.Cells(i, j)) = False Then Sheet2.Cells(i, j).Interior.ColorIndex = 6
Next j, i
MsgBox "处理完成，请查看。"
End Sub【6】国家审核整合
Sub combine()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = Worksheets.Count To 1 Step -1
If Worksheets(i).Name <> Sheets(1).Name Then Worksheets(i).Delete
Next
'新建一个对话框对象
Set FolderDialogObject = Application.FileDialog(msoFileDialogFolderPicker)
With FolderDialogObject
.Title = "请选择要合并的文件夹"
.InitialFileName = "C:\"
End With
FolderDialogObject.Show
Set paths = FolderDialogObject.SelectedItems
If paths.Count = 0 Then Exit Sub
mydir = paths(1)
Dim myfile, Arr
myfile = Dir(mydir & "\*.*")
j = 1
Do While myfile <> ""
Set xlbook1 = GetObject(mydir & "\" & myfile)
For i = 1 To xlbook1.Worksheets.Count
Cells(1, 9 + j) = j
Worksheets.Add after:=Sheets(Sheets.Count)
j = j + 1
Sheets(j).Name = j - 1
xlbook1.Sheets(i).UsedRange.Copy Sheets(j).Cells(1, 4)
Sheets(j).Cells(1, 1) = xlbook1.Sheets(i).Name
Sheets(j).Hyperlinks.Add Anchor:=Sheets(j).Cells(1, 1), Address:="", SubAddress:="审核汇总!H1"
Sheets(j).Cells(1, 1).WrapText = True
Next
xlbook1.Close False
myfile = Dir
Loop
'Range(Cells(1, 10), Cells(1, j + 8)).EntireColumn.AutoFit
Range(Cells(1, 10), Cells(1, j + 8)).ColumnWidth = 4
For i = 2 To Worksheets.Count
Set Rng1 = Sheets(i).UsedRange.Find("coun")
Set Rng2 = Sheets(i).UsedRange.Find("sid")
k = Sheets(i).UsedRange.Rows.Count
If Not Rng1 Is Nothing Then
Sheets(i).Range(Sheets(i).Cells(1, Rng1.Column), Sheets(i).Cells(k, Rng1.Column)).Copy Sheets(i).Cells(1, 2)
ElseIf Not Rng2 Is Nothing Then
Sheets(i).Range(Sheets(i).Cells(1, Rng2.Column), Sheets(i).Cells(k, Rng2.Column)).Copy Sheets(i).Cells(1, 3)
Sheets(i).Cells(1, 2) = "coun"
Sheets(i).Cells(2, 2) = "=VLOOKUP(LEFT(C2,15),审核汇总!A:B,2,0)"
Sheets(i).Range("B2:B" & k).FillDown
Sheets(i).UsedRange = Sheets(i).UsedRange.Value
Sheets(i).Range("C2:C" & k).Clear
End If
Sheets(i).Cells(1, 3) = "说明"
Next
For i = 2 To 62
For j = 10 To UsedRange.Columns.Count
Cells(i, j) = "=countif( " & Cells(1, j) & "!B:B,H" & i & ")"
If Cells(i, j) <> 0 Then Sheets(1).Hyperlinks.Add Anchor:=Cells(i, j), Address:="", SubAddress:=Cells(1, j) & "!A1"
Next j
Next i
Sheet1.Activate
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column > 9 And Cells(1, Target.Column) <> "" Then
Cells(1, Target.Column).Interior.ColorIndex = 6
Cells(Target.Row, Target.Column).Interior.ColorIndex = 6
End If
End Sub【7】SAS数据拆分
options validvarname=any; data cxh.a; infile "d:\1.txt" firstobs=1 dlm='陈燮函'; informat 问题1 $2000. 问题2 $2000. 问题3 $2000.; input 问题3 $; 说明=''; 问题2=lag(问题3); 问题1=lag2(问题3); if kindex(问题1,'提示')=0 then delete; if kindex(问题2,'提示')>0 then 问题2=''; if kindex(问题3,'提示')>0 then 问题3=''; if 问题2='' then 问题3=''; run; data a610102 a610103 a610104 a610111 a610113 a610114 else; set cxh.a; keep 问题1 问题2 问题3 说明; if index(问题1,'610102')>0 then output a610102; if index(问题1,'610103')>0 then output a610103; if index(问题1,'610104')>0 then output a610104; if index(问题1,'610111')>0 then output a610111; if index(问题1,'610113')>0 then output a610113; if index(问题1,'610114')>0 then output a610114; else output else; run; proc export data=a610102 outfile="d:\a610102.csv"; proc export data=a610103 outfile="d:\a610103.csv"; proc export data=a610104 outfile="d:\a610104.csv"; proc export data=a610111 outfile="d:\a610111.csv"; proc export data=a610113 outfile="d:\a610113.csv"; proc export data=a610114 outfile="d:\a610114.csv"; run;
