Excel VBA 每天一段代码：分权限查阅，每个用户看到不同数据

大家好，欢迎来到IT知识分享网。

如上图所示，从系统导出的数据包含若干个分公司的几万行数据，现要求将每个分公司的数据分发给各分公司。

以前的做法是：以公司编号一列拆分为新工作簿，再将新文件分发给各分公司。如果公司数量较多，发送给相应分公司文件，工作量较大。

下面给大家介绍一种新方法：以公司编号为登录名、分配密码打开同一个文件，每个分公司看到的数据不一样。演示视频如下：

代码（一）设置用户名和密码

‘功能：提取汇总表公司编号作为登录账户，并随机生成4位数的登录密码（含大小写字母或数字）

Private Sub CommandButton1_Click()

On Error Resume Next

Dim arr, brr, i&, d As Object, d1 As Object

Dim password As String

Set d = CreateObject(“scripting.dictionary”)

Set d1 = CreateObject(“scripting.dictionary”)

arr = Sheets(“汇总”).Range(“A1”).CurrentRegion

brr = Range(“A1”).CurrentRegion

‘将已存在的账户写入字典d

For i = 2 To UBound(brr)

If brr(i, 1) <> “admin” Then d.Add brr(i, 1), “”

Next i

‘提取不重复的公司编号写入字典d1

For i = 3 To UBound(arr)

If Not d.Exists(arr(i, 1)) Then

password = GeneratePassword(4) ‘ 生成一个长度为6的随机密码

d1.Add arr(i, 1), password

End If

Next i

If d1.Count < 1 Then MsgBox “没有新增的公司编号！”, vbCritical, “错误！”: Exit Sub

j = Cells(Rows.Count, 1).End(xlUp).Row + 1

Range(“A” & j).Resize(d1.Count, 1) = WorksheetFunction.Transpose(d1.Keys)

Range(“B” & j).Resize(d1.Count, 1) = WorksheetFunction.Transpose(d1.Items)

Range(“D” & j).Resize(d1.Count, 1) = 1

‘释放字典内存

d.RemoveAll: Set d = Nothing

d1.RemoveAll: Set d1 = Nothing

End Sub

代码（二）登录验证 请翻阅往期视频，此处省略

代码（三）查询本公司数据 代码写到模块之中

Function 数据查询(bm As String)

Dim arr, brr(1 To , 1 To 9), i&, j%, n&

h = Sheets(“数据展示”).Cells(Rows.Count, “G”).Row

If h >= 3 Then

Sheets(“数据展示”).Range(“A3:I” & h).ClearContents

End If

If bm = “admin” Then Exit Function

arr = Sheets(“汇总”).UsedRange

For i = 3 To UBound(arr)

If VBA.InStr(arr(i, 1), bm) > 0 Then

n = n + 1

For j = 1 To UBound(arr, 2)

brr(n, j) = arr(i, j)

Next j

End If

Next i

For i = 1 To UBound(brr)

brr(i, 2) = VBA.Format(brr(i, 2), “yyyy/mm/dd hh:mm:ss”)

brr(i, 3) = VBA.Format(brr(i, 3), “yyyy/mm/dd hh:mm:ss”)

Next i

Sheets(“数据展示”).Range(“A3”).Resize(n, 9) = brr

End Function

调用方法：数据查询 (TextBox1.Text)

TextBox1.Text 即登录界面输入的用户名（公司编码）

— The End

完整文件请留言索取