VBA – 根据input的密码过滤显示的单元格

我（尝试）创build一个基于input的密码过滤Sheet1的VBA代码。 我有一个Excel表格的2个文件和Sheet2有密码在B列和“filter”在A列。我将分发的Excel文件，并提供相应的密码，各方当他们input密码所有信息从其他各方将被删除。 代码：

Sub Open_with_password() pas = Application.InputBox("Input password") If pas = False Or pas = "" Then Exit Sub Application.ScreenUpdating = False a = 0 For i = 1 To Sheet2.Range("A1").End(xlDown).Row If Worksheets("Sheet2").Cells(i, 2) = pas Then c = Worksheets("Sheet2").Cells(i, 1) 'the agency corresponding with the password a = a + 1 End If Next 'Check for password If a = 0 Then MsgBox "Wrong password. Report can not be accessed" ActiveWorkbook.Close False Sheet2.Visible = xlSheetVeryHidden Sheet1.Visible = xlSheetVeryHidden Exit Sub 'If correct password Else: Sheet1.Visible = xlSheetVisible Worksheets("Sheet1").Select Worksheets("Sheet1").Unprotect Password = "XYZ" On Error Resume Next ActiveSheet.ShowAllData On Error GoTo 0 'Filter according to input password If c <> "Admin" Then ActiveSheet.Range("$A$2:$AQ$500000").AutoFilter Field:=17, Criteria1:=c Set rCell = ActiveSheet.AutoFilter.Range.Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells(1, 1) Rows(rCell.Row).Select Range(Selection, Selection.End(xlDown)).Copy Worksheets("Sheet1").Select Range("A2").Select Selection.PasteSpecial Paste:=xlPasteValues, _ Operation:=xlNone, SkipBlanks:=False, Transpose:=False Range("A2").Select 'If Admin If c = "Admin" Then Sheet2.Visible = xlSheetVisible Sheet1.Visible = xlSheetVisible End If End If Application.ScreenUpdating = True End Sub 

我到目前为止遇到的问题是：
1.当我打开文件，input框不会自动显示，理想情况下，它会显示，而用户什么都看不到。
2.当它根据密码进行过滤（filter工作），当它到达它想要删除其他所有的部分时，它不会。 我正在使用复制和粘贴方法，并popup一个错误（错误1004）

非常感谢您的帮助

Answer 1

build议：

工作簿打开时调用您的macros。

 Private Sub Workbook_Open（）
     Open_with_password
结束小组

我会保持你的数据完整的隐藏工作表。

Sheet1.Visible = xlSheetVeryHidden

将过滤的单元格复制到不同的工作表

设置rCell = ActiveSheet.AutoFilter.Range.SpecialCells（xlCellTypeVisible）
 rcell.Copy Sheet2.Range（“A1”）

当工作簿closures时清除Sheet2。

 Private Sub Workbook_BeforeClose（取消为布尔）
     Sheet2.Cells.ClearContents
结束小组

如果这样做，用户在打开工作簿而不启用macros时将无法访问隐藏的数据。

Answer 2

1.Code应该在Workbook_Open()事件上，你可以调用另一个子我的build议。 在“ThisWorkbook”对象中：

 Private Sub Workbook_Open() Call Open_with_password End Sub 

2.如果你使用复制粘贴，你不能在中间做一个select，这样做会丢失剪贴板（在Excel VBA中的正常行为），因此你将无法粘贴，因此错误。

 Rows(rCell.Row).Select Range(Selection, Selection.End(xlDown)).Copy Worksheets("Sheet1").Select Range("A2").Select 'lost clipboard Selection.PasteSpecial Paste:=xlPasteValues, _ Operation:=xlNone, SkipBlanks:=False, Transpose:=False Range("A2").Select 

为。。改变

 Rows(rCell.Row).Select Range(Selection, Selection.End(xlDown)).Copy Sheets("Sheet1").Range("A2").PasteSpecial Paste:=xlPasteValues Excel.Application.CutCopyMode = False 'clears clipboard 

编辑：

不pipe有没有filter，它都应该工作。
OT：下一步你会search如何避免select（这是非常耗时）。

Answer 3

我正在回答我自己的问题，因为我使用了下面的解决scheme，它似乎工作：

 Private Sub Workbook_Open() Call Open_with_password End Sub 

＆

 Sub Open_with_password() Sheet2.Visible = xlSheetHidden Sheet1.Visible = xlSheetHidden Sheet3.Cells.ClearContents Sheet1.Range("A1", "AQ1").Copy Sheet3.Range("A1").PasteSpecial Paste:=xlPasteValues Application.ScreenUpdating = False pas = Application.InputBox("Input password") If pas = False Or pas = "" Then Exit Sub a = 0 For i = 1 To Sheet2.Range("A1").End(xlDown).Row If Worksheets("Sheet2").Cells(i, 2) = pas Then c = Worksheets("Sheet2").Cells(i, 1) 'the agency corresponding with the password a = a + 1 End If Next 'Check for password If a = 0 Then MsgBox "Wrong password. Report can not be accessed" ActiveWorkbook.Close False Sheet2.Visible = xlSheetVeryHidden Sheet1.Visible = xlSheetVeryHidden Exit Sub 'If correct password Else: Sheet1.Visible = xlSheetVisible Worksheets("Sheet1").Select Worksheets("Sheet1").Unprotect Password = "amazon" On Error Resume Next ActiveSheet.ShowAllData On Error GoTo 0 'Filter according to input password If c <> "Admin" Then ActiveSheet.Range("$A$2:$AQ$500000").AutoFilter Field:=17, Criteria1:=c Set rCell = ActiveSheet.AutoFilter.Range.Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells(1, 1) Rows(rCell.Row).Select Range(Selection, Selection.End(xlDown)).Copy Sheets("Sheet3").Range("A2").PasteSpecial Paste:=xlPasteValues Excel.Application.CutCopyMode = False 'clears clipboard Sheet1.Visible = xlSheetVeryHidden 'If Admin If c = "Admin" Then Sheet2.Visible = xlSheetVisible Sheet1.Visible = xlSheetVisible End If End If Application.ScreenUpdating = True End Sub